Theory Lib

(*  Title:       Lib.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Generic functions and lemmas"

theory Lib
imports Main
begin

definition
  TT :: "'a  bool"
where
  "TT = (λ_. True)"

lemma TT_True [intro, simp]: "TT a"
  unfolding TT_def by simp

lemma in_set_tl: "x  set (tl xs)  x  set xs"
  by (metis Nil_tl insert_iff list.collapse set_simps(2))

lemma nat_le_eq_or_lt [elim]:
    fixes x :: nat
  assumes "x  y"
      and eq: "x = y  P x y"
      and lt: "x < y  P x y"
    shows "P x y"
  using assms unfolding nat_less_le by auto

lemma disjoint_commute:
  "(A  B = {})  (B  A = {})"
  by auto

definition
  default :: "('i  's)  ('i  's option)  ('i  's)"
where
  "default df f = (λi. case f i of None  df i | Some s  s)"

end

Theory TransitionSystems

(*  Title:       TransitionSystems.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Transition systems (automata)"

theory TransitionSystems
imports Main
begin

type_synonym ('s, 'a) transition = "'s × 'a × 's"

record ('s, 'a) automaton =
  init :: "'s set"
  trans :: "('s, 'a) transition set"

end

Theory Invariants

(*  Title:       Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Reachability and Invariance"

theory Invariants
imports Lib TransitionSystems
begin

subsection Reachability

text ‹
  A state is `reachable' under @{term I} if either it is the initial state, or it is the
  destination of a transition whose action satisfies @{term I} from a reachable state.
  The `standard' definition of reachability is recovered by setting @{term I} to @{term TT}.
›

inductive_set reachable
  for A :: "('s, 'a) automaton"
  and I :: "'a  bool"
where
    reachable_init: "s  init A  s  reachable A I"
  | reachable_step: " s  reachable A I; (s, a, s')  trans A; I a   s'  reachable A I"

inductive_cases reachable_icases: "s  reachable A I"

lemma reachable_pair_induct [consumes, case_names init step]:
  assumes "(ξ, p)  reachable A I"
      and "ξ p. (ξ, p)  init A  P ξ p"
      and "(ξ p ξ' p' a.  (ξ, p)  reachable A I; P ξ p;
                            ((ξ, p), a, (ξ', p'))  trans A; I a   P ξ' p')"
    shows "P ξ p"
  using assms(1) proof (induction "(ξ, p)" arbitrary: ξ p)
    fix ξ p
    assume "(ξ, p)  init A"
    with assms(2) show "P ξ p" .
  next
    fix s a ξ' p'
    assume "s  reachable A I"
       and tr: "(s, a, (ξ', p'))  trans A"
       and "I a"
       and IH: "ξ p. s = (ξ, p)  P ξ p"
    from this(1) obtain ξ p where "s = (ξ, p)"
                              and "(ξ, p)  reachable A I"
      by (metis prod.collapse)
    note this(2)
    moreover from IH and s = (ξ, p) have "P ξ p" .
    moreover from tr and s = (ξ, p) have "((ξ, p), a, (ξ', p'))  trans A" by simp
    ultimately show "P ξ' p'"
      using I a by (rule assms(3))
  qed

lemma reachable_weakenE [elim]:
  assumes "s  reachable A P"
      and PQ: "a. P a  Q a"
    shows "s  reachable A Q"
  using assms(1)
  proof (induction)
    fix s assume "s  init A"
    thus "s  reachable A Q" ..
  next
    fix s a s'
    assume "s  reachable A P"
       and "s  reachable A Q"
       and "(s, a, s')  trans A"
       and "P a"
    from P a have "Q a" by (rule PQ)
    with s  reachable A Q and (s, a, s')  trans A show "s'  reachable A Q" ..
  qed

lemma reachable_weaken_TT [elim]:
  assumes "s  reachable A I"
    shows "s  reachable A TT"
  using assms by rule simp

lemma init_empty_reachable_empty:
  assumes "init A = {}"
    shows "reachable A I = {}"
  proof (rule ccontr)
    assume "reachable A I  {}"
    then obtain s where "s  reachable A I" by auto
    thus False
    proof (induction rule: reachable.induct)
      fix s
      assume "s  init A"
      with ‹init A = {} show False by simp
    qed
  qed

subsection Invariance

definition invariant
  :: "('s, 'a) automaton  ('a  bool)  ('s  bool)  bool"
  ("_  (1'(_ →')/ _)" [100, 0, 9] 8)
where
  "(A  (I →) P) = (sreachable A I. P s)"

abbreviation
  any_invariant
  :: "('s, 'a) automaton  ('s  bool)  bool"
  ("_  _" [100, 9] 8)
where
  "(A  P)  (A  (TT →) P)"

lemma invariantI [intro]:
  assumes init: "s. s  init A  P s"
      and step: "s a s'.  s  reachable A I; P s; (s, a, s')  trans A; I a   P s'"
    shows "A  (I →) P"
  unfolding invariant_def
  proof
       fix s
    assume "s  reachable A I"
      thus "P s"
    proof induction
      fix s assume "s  init A"
      thus "P s" by (rule init)
    next
      fix s a s'
      assume "s  reachable A I"
         and "P s"
         and "(s, a, s')  trans A"
         and "I a"
        thus "P s'" by (rule step)
    qed
  qed

lemma invariant_pairI [intro]:
  assumes init: "ξ p. (ξ, p)  init A  P (ξ, p)"
      and step: "ξ p ξ' p' a.
                    (ξ, p)  reachable A I; P (ξ, p); ((ξ, p), a, (ξ', p'))  trans A; I a 
                    P (ξ', p')"
    shows "A  (I →) P"
  using assms by auto

lemma invariant_arbitraryI:
  assumes "s. s  reachable A I  P s"
    shows "A  (I →) P"
  using assms unfolding invariant_def by simp

lemma invariantD [dest]:
  assumes "A  (I →) P"
      and "s  reachable A I"
    shows "P s"
  using assms unfolding invariant_def by blast

lemma invariant_initE [elim]:
  assumes invP: "A  (I →) P"
      and init: "s  init A"
    shows "P s"
  proof -
    from init have "s  reachable A I" ..
    with invP show ?thesis ..
  qed

lemma invariant_weakenE [elim]:
  fixes T σ P Q
  assumes invP: "A  (PI →) P"
      and PQ:   "s. P s  Q s"
      and QIPI: "a. QI a  PI a"
    shows       "A  (QI →) Q"
  proof
    fix s
    assume "s  init A"
    with invP have "P s" ..
    thus "Q s" by (rule PQ)
  next
    fix s a s'
    assume "s  reachable A QI"
       and "(s, a, s')  trans A"
       and "QI a"
    from QI a have "PI a" by (rule QIPI)
    from s  reachable A QI and QIPI have "s  reachable A PI" ..
    hence "s'  reachable A PI" using (s, a, s')  trans A and PI a ..
    with invP have "P s'" ..
    thus "Q s'" by (rule PQ)
  qed

definition
  step_invariant
  :: "('s, 'a) automaton  ('a  bool)  (('s, 'a) transition  bool)  bool"
  ("_ A (1'(_ →')/ _)" [100, 0, 0] 8)
where
  "(A A (I →) P) = (a. I a  (sreachable A I. (s'.(s, a, s')  trans A  P (s, a, s'))))"

lemma invariant_restrict_inD [dest]:
  assumes "A  (TT →) P"
    shows "A  (QI →) P"
  using assms by auto

abbreviation
  any_step_invariant
  :: "('s, 'a) automaton  (('s, 'a) transition  bool)  bool"
  ("_ A _" [100, 9] 8)
where
  "(A A P)  (A A (TT →) P)"

lemma step_invariant_true:
  "p A (λ(s, a, s'). True)"
  unfolding step_invariant_def by simp

lemma step_invariantI [intro]:
  assumes *: "s a s'.  sreachable A I; (s, a, s')trans A; I a   P (s, a, s')"
    shows "A A (I →) P"
  unfolding step_invariant_def
  using assms by auto

lemma step_invariantD [dest]:
  assumes "A A (I →) P"
      and "sreachable A I"
      and "(s, a, s')  trans A"
      and "I a"
    shows "P (s, a, s')"
  using assms unfolding step_invariant_def by blast

lemma step_invariantE [elim]:
    fixes T σ P I s a s'
  assumes "A A (I →) P"
      and "sreachable A I"
      and "(s, a, s')  trans A"
      and "I a"
      and "P (s, a, s')  Q"
    shows "Q"
  using assms by auto

lemma step_invariant_pairI [intro]:
  assumes *: "ξ p ξ' p' a.
               (ξ, p)  reachable A I; ((ξ, p), a, (ξ', p'))  trans A; I a 
                                                        P ((ξ, p), a, (ξ', p'))"
    shows "A A (I →) P"
  using assms by auto

lemma step_invariant_arbitraryI:
  assumes "ξ p a ξ' p'.  (ξ, p)  reachable A I; ((ξ, p), a, (ξ', p'))  trans A; I a 
            P ((ξ, p), a, (ξ', p'))"
    shows "A A (I →) P"
  using assms by auto

lemma step_invariant_weakenE [elim!]:
  fixes T σ P Q
  assumes invP: "A A (PI →) P"
      and PQ:   "t. P t  Q t"
      and QIPI: "a. QI a  PI a"
    shows       "A A (QI →) Q"
  proof
    fix s a s'
    assume "s  reachable A QI"
       and "(s, a, s')  trans A"
       and "QI a"
    from QI a have "PI a" by (rule QIPI)
    from s  reachable A QI have "s  reachable A PI" using QIPI ..
    with invP have "P (s, a, s')" using (s, a, s')  trans A PI a ..
    thus "Q (s, a, s')" by (rule PQ)
  qed

lemma step_invariant_weaken_with_invariantE [elim]:
  assumes pinv: "A  (I →) P"
      and qinv: "A A (I →) Q"
      and wr: "s a s'.  P s; P s'; Q (s, a, s'); I a   R (s, a, s')"
    shows "A A (I →) R"
  proof
    fix s a s'
    assume sr: "s  reachable A I"
       and tr: "(s, a, s')  trans A"
       and "I a"
    hence "s'  reachable A I" ..
    with pinv have "P s'" ..
    from pinv and sr have "P s" ..
    from qinv sr tr I a have "Q (s, a, s')" ..
    with P s and P s' show "R (s, a, s')" using I a by (rule wr)
  qed

lemma step_to_invariantI:
  assumes sinv: "A A (I →) Q"
      and init: "s. s  init A  P s"
      and step: "s s' a.
                    s  reachable A I;
                     P s;
                     Q (s, a, s');
                     I a   P s'"
    shows "A  (I →) P"
  proof
    fix s assume "s  init A" thus "P s" by (rule init)
  next
    fix s s' a
    assume "s  reachable A I"
       and "P s"
       and "(s, a, s')  trans A"
       and "I a"
      show "P s'"
    proof -
      from sinv and sreachable A I and (s, a, s')trans A and I a have "Q (s, a, s')" ..
      with sreachable A I and P s show "P s'" using I a by (rule step)
    qed
  qed

end

Theory OInvariants

(*  Title:       OInvariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Open reachability and invariance"

theory OInvariants
imports Invariants
begin

subsection "Open reachability"

text ‹
  By convention, the states of an open automaton are pairs. The first component is considered
  to be the global state and the second is the local state.

  A state is `open reachable' under @{term S} and @{term U} if it is the initial state, or it
  is the destination of a transition---where the global components satisfy @{term S}---from an
  open reachable state, or it is the destination of an interleaved environment step where the
  global components satisfy @{term U}.
›

inductive_set oreachable
  :: "('g × 'l, 'a) automaton
       ('g  'g  'a  bool)
       ('g  'g  bool)
       ('g × 'l) set"
  for A  :: "('g × 'l, 'a) automaton"
  and S  :: "'g  'g  'a  bool"
  and U  :: "'g  'g  bool"
where
    oreachable_init: "s  init A  s  oreachable A S U"
  | oreachable_local: " s  oreachable A S U; (s, a, s')  trans A; S (fst s) (fst s') a 
                         s'  oreachable A S U"
  | oreachable_other: " s  oreachable A S U; U (fst s) σ' 
                         (σ', snd s)  oreachable A S U"

lemma oreachable_local' [elim]:
  assumes "(σ, p)  oreachable A S U"
      and "((σ, p), a, (σ', p'))  trans A"
      and "S σ σ' a"
    shows "(σ', p')  oreachable A S U"
  using assms by (metis fst_conv oreachable.oreachable_local)

lemma oreachable_other' [elim]:
  assumes "(σ, p)  oreachable A S U"
      and "U σ σ'"
    shows "(σ', p)  oreachable A S U"
  proof -
    from U σ σ' have "U (fst (σ, p)) σ'" by simp
    with (σ, p)  oreachable A S U have "(σ', snd (σ, p))  oreachable A S U"
      by (rule oreachable_other)
    thus "(σ', p)  oreachable A S U" by simp
  qed

lemma oreachable_pair_induct [consumes, case_names init other local]:
  assumes "(σ, p)  oreachable A S U"
      and "σ p. (σ, p)  init A  P σ p"
      and "(σ p σ'.  (σ, p)  oreachable A S U; P σ p; U σ σ'   P σ' p)"
      and "(σ p σ' p' a.  (σ, p)  oreachable A S U; P σ p;
                            ((σ, p), a, (σ', p'))  trans A; S σ σ' a   P σ' p')"
    shows "P σ p"
  using assms (1) proof (induction "(σ, p)" arbitrary: σ p)
    fix σ p
    assume "(σ, p)  init A"
    with assms(2) show "P σ p" .
  next
    fix s σ'
    assume "s  oreachable A S U"
       and "U (fst s) σ'"
       and IH: "σ p. s = (σ, p)  P σ p"
    from this(1) obtain σ p where "s = (σ, p)"
                              and "(σ, p)  oreachable A S U"
      by (metis surjective_pairing)
    note this(2)
    moreover from IH and s = (σ, p) have "P σ p" .
    moreover from U (fst s) σ' and s = (σ, p) have "U σ σ'" by simp
    ultimately have "P σ' p" by (rule assms(3))
    with s = (σ, p) show "P σ' (snd s)" by simp
  next
    fix s a σ' p'
    assume "s  oreachable A S U"
       and tr: "(s, a, (σ', p'))  trans A"
       and "S (fst s) (fst (σ', p')) a"
       and IH: "σ p. s = (σ, p)  P σ p"
    from this(1) obtain σ p where "s = (σ, p)"
                              and "(σ, p)  oreachable A S U"
      by (metis surjective_pairing)
    note this(2)
    moreover from IH s = (σ, p) have "P σ p" .
    moreover from tr and s = (σ, p) have "((σ, p), a, (σ', p'))  trans A" by simp
    moreover from S (fst s) (fst (σ', p')) a and s = (σ, p) have "S σ σ' a" by simp
    ultimately show "P σ' p'" by (rule assms(4))
  qed

lemma oreachable_weakenE [elim]:
  assumes "s  oreachable A PS PU"
      and PSQS: "s s' a. PS s s' a  QS s s' a"
      and PUQU: "s s'.   PU s s'    QU s s'"
    shows "s  oreachable A QS QU"
  using assms(1)
  proof (induction)
    fix s assume "s  init A"
    thus "s  oreachable A QS QU" ..
  next
    fix s a s'
    assume "s  oreachable A QS QU"
       and "(s, a, s')  trans A"
       and "PS (fst s) (fst s') a"
    from PS (fst s) (fst s') a have "QS (fst s) (fst s') a" by (rule PSQS)
    with s  oreachable A QS QU and (s, a, s')  trans A show "s'  oreachable A QS QU" ..
  next
    fix s g'
    assume "s  oreachable A QS QU"
       and "PU (fst s) g'"
    from PU (fst s) g' have "QU (fst s) g'" by (rule PUQU)
    with s  oreachable A QS QU show "(g', snd s)  oreachable A QS QU" ..
  qed

definition
  act :: "('a  bool)  's  's  'a  bool"
where
  "act I  (λ_ _. I)"

lemma act_simp [iff]: "act I s s' a = I a"
  unfolding act_def ..

lemma reachable_in_oreachable [elim]:
    fixes s
  assumes "s  reachable A I"
    shows "s  oreachable A (act I) U"
  unfolding act_def using assms proof induction
    fix s
    assume "s  init A"
    thus "s  oreachable A (λ_ _. I) U" ..
  next
    fix s a s'
    assume "s  oreachable A (λ_ _. I) U"
       and "(s, a, s')  trans A"
       and "I a"
    thus "s'  oreachable A (λ_ _. I) U"
      by (rule oreachable_local)
  qed

subsection "Open Invariance"

definition oinvariant
  :: "('g × 'l, 'a) automaton
       ('g  'g  'a  bool)  ('g  'g  bool)
       (('g × 'l)  bool)  bool"
  ("_  (1'((1_),/ (1_) →')/ _)" [100, 0, 0, 9] 8)
where
  "(A  (S, U →) P) = (soreachable A S U. P s)"

lemma oinvariantI [intro]:
    fixes T TI S U P
  assumes init: "s. s  init A  P s"
      and other: "g g' l.
                   (g, l)  oreachable A S U; P (g, l); U g g'   P (g', l)"
      and local: "s a s'.
                   s  oreachable A S U; P s; (s, a, s')  trans A; S (fst s) (fst s') a   P s'"
    shows "A  (S, U →) P"
  unfolding oinvariant_def
  proof
       fix s
    assume "s  oreachable A S U"
      thus "P s"
    proof induction
      fix s assume "s  init A"
      thus "P s" by (rule init)
    next
      fix s a s'
      assume "s  oreachable A S U"
         and "P s"
         and "(s, a, s')  trans A"
         and "S (fst s) (fst s') a"
        thus "P s'" by (rule local)
     next
       fix s g'
       assume "s  oreachable A S U"
          and "P s"
          and "U (fst s) g'"
         thus "P (g', snd s)"
           by - (rule other [where g="fst s"], simp_all)
    qed
  qed

lemma oinvariant_oreachableI:
  assumes "σ s. (σ, s)oreachable A S U  P (σ, s)"
  shows "A  (S, U →) P"
  using assms unfolding oinvariant_def by auto

lemma oinvariant_pairI [intro]:
  assumes init: "σ p. (σ, p)  init A  P (σ, p)"
      and local: "σ p σ' p' a.
                    (σ, p)  oreachable A S U; P (σ, p); ((σ, p), a, (σ', p'))  trans A;
                     S σ σ' a   P (σ', p')"
      and other: "σ σ' p.
                   (σ, p)  oreachable A S U; P (σ, p); U σ σ'   P (σ', p)"
    shows "A  (S, U →) P"
  by (rule oinvariantI)
     (clarsimp | erule init | erule(3) local | erule(2) other)+

lemma oinvariantD [dest]:
  assumes "A  (S, U →) P"
      and "s  oreachable A S U"
    shows "P s"
  using assms unfolding oinvariant_def
  by clarsimp

lemma oinvariant_initD [dest, elim]:
  assumes invP: "A  (S, U →) P"
      and init: "s  init A"
    shows "P s"
  proof -
    from init have "s  oreachable A S U" ..
    with invP show ?thesis ..
  qed

lemma oinvariant_weakenE [elim!]:
  assumes invP: "A  (PS, PU →) P"
      and PQ:   "s. P s  Q s"
      and QSPS: "s s' a. QS s s' a  PS s s' a"
      and QUPU: "s s'.   QU s s'    PU s s'"
    shows       "A  (QS, QU →) Q"
  proof
    fix s
    assume "s  init A"
    with invP have "P s" ..
    thus "Q s" by (rule PQ)
  next
    fix σ p σ' p' a
    assume "(σ, p)  oreachable A QS QU"
       and "((σ, p), a, (σ', p'))  trans A"
       and "QS σ σ' a"
    from this(3) have "PS σ σ' a" by (rule QSPS)
    from (σ, p)  oreachable A QS QU and QSPS QUPU have "(σ, p)  oreachable A PS PU" ..
    hence "(σ', p')  oreachable A PS PU" using ((σ, p), a, (σ', p'))  trans A and PS σ σ' a ..
    with invP have "P (σ', p')" ..
    thus "Q (σ', p')" by (rule PQ)
  next
    fix σ σ' p
    assume "(σ, p)  oreachable A QS QU"
       and "Q (σ, p)"
       and "QU σ σ'"
    from QU σ σ' have "PU σ σ'" by (rule QUPU)
    from (σ, p)  oreachable A QS QU and QSPS QUPU have "(σ, p)  oreachable A PS PU" ..
    hence "(σ', p)  oreachable A PS PU" using PU σ σ' ..
    with invP have "P (σ', p)" ..
    thus "Q (σ', p)" by (rule PQ)
  qed

lemma oinvariant_weakenD [dest]:
  assumes "A  (S', U' →) P"
      and "(σ, p)  oreachable A S U"
      and weakenS: "s s' a. S s s' a  S' s s' a"
      and weakenU: "s s'. U s s'  U' s s'"
    shows "P (σ, p)"
  proof -
    from (σ, p)  oreachable A S U have "(σ, p)  oreachable A S' U'"
      by (rule oreachable_weakenE)
         (erule weakenS, erule weakenU)
    with A  (S', U' →) P show "P (σ, p)" ..
  qed

lemma close_open_invariant:
  assumes oinv: "A  (act I, U →) P"
    shows "A  (I →) P"
  proof
    fix s
    assume "s  init A"
    with oinv show "P s" ..
  next
    fix ξ p ξ' p' a
    assume sr: "(ξ, p)  reachable A I"
       and step: "((ξ, p), a, (ξ', p'))  trans A"
       and "I a"
    hence "(ξ', p')  reachable A I" ..
    hence "(ξ', p')  oreachable A (act I) U" ..
    with oinv show "P (ξ', p')" ..
  qed

definition local_steps :: "((('i  's1) × 'l1) × 'a × ('i  's2) × 'l2) set  'i set  bool"
where "local_steps T J 
   (σ ζ s a σ' s'. ((σ, s), a, (σ', s'))  T  (jJ. ζ j = σ j)
    (ζ'. (jJ. ζ' j = σ' j)  ((ζ, s), a, (ζ', s'))  T))"

lemma local_stepsI [intro!]:
  assumes "σ ζ s a σ' ζ' s'.  ((σ, s), a, (σ', s'))  T; jJ. ζ j = σ j 
                                (ζ'. (jJ. ζ' j = σ' j)  ((ζ, s), a, (ζ', s'))  T)"
    shows "local_steps T J"
  unfolding local_steps_def using assms by clarsimp

lemma local_stepsE [elim, dest]:
  assumes "local_steps T J"
      and "((σ, s), a, (σ', s'))  T"
      and "jJ. ζ j = σ j"
    shows "ζ'. (jJ. ζ' j = σ' j)  ((ζ, s), a, (ζ', s'))  T"
  using assms unfolding local_steps_def by blast

definition other_steps :: "(('i  's)  ('i  's)  bool)  'i set  bool"
where "other_steps U J  σ σ'. U σ σ'  (jJ. σ' j = σ j)"

lemma other_stepsI [intro!]:
  assumes "σ σ' j.  U σ σ'; j  J   σ' j = σ j"
    shows "other_steps U J"
  using assms unfolding other_steps_def by simp

lemma other_stepsE [elim]:
  assumes "other_steps U J"
      and "U σ σ'"
    shows "jJ. σ' j = σ j"
  using assms unfolding other_steps_def by simp

definition subreachable
where "subreachable A U J  I. s  oreachable A (λs s'. I) U.
                                  (σ. (jJ. σ j = (fst s) j)  (σ, snd s)  reachable A I)"

lemma subreachableI [intro]:
  assumes "local_steps (trans A) J"
      and "other_steps U J"
    shows "subreachable A U J"
  unfolding subreachable_def
  proof (rule, rule)
    fix I s
    assume "s  oreachable A (λs s'. I) U"
    thus "(σ. (jJ. σ j = (fst s) j)  (σ, snd s)  reachable A I)"
    proof induction
      fix s
      assume "s  init A"
      hence "(fst s, snd s)  reachable A I"
        by simp (rule reachable_init)
      moreover have "jJ. (fst s) j = (fst s) j"
        by simp
      ultimately show "σ. (jJ. σ j = (fst s) j)  (σ, snd s)  reachable A I"
        by auto
    next
      fix s a s'
      assume "σ. (jJ. σ j = (fst s) j)  (σ, snd s)  reachable A I"
         and "(s, a, s')  trans A"
         and "I a"
      then obtain ζ where "jJ. ζ j = (fst s) j"
                      and "(ζ, snd s)  reachable A I" by auto

      from (s, a, s')  trans A have "((fst s, snd s), a, (fst s', snd s'))  trans A"
        by simp
      with ‹local_steps (trans A) J obtain ζ' where "jJ. ζ' j = (fst s') j"
                                                 and "((ζ, snd s), a, (ζ', snd s'))  trans A"
        using jJ. ζ j = (fst s) j by - (drule(2) local_stepsE, clarsimp)
      from (ζ, snd s)  reachable A I
       and ((ζ, snd s), a, (ζ', snd s'))  trans A
       and I a
       have "(ζ', snd s')  reachable A I" ..

      with jJ. ζ' j = (fst s') j
        show "σ. (jJ. σ j = (fst s') j)  (σ, snd s')  reachable A I" by auto
    next
      fix s σ'
      assume "σ. (jJ. σ j = (fst s) j)  (σ, snd s)  reachable A I"
         and "U (fst s) σ'"
      then obtain σ where "jJ. σ j = (fst s) j"
                      and "(σ, snd s)  reachable A I" by auto
      from ‹other_steps U J and U (fst s) σ' have "jJ. σ' j = (fst s) j"
        by - (erule(1) other_stepsE)
      with jJ. σ j = (fst s) j have "jJ. σ j = σ' j"
        by clarsimp
      with (σ, snd s)  reachable A I
       show "σ. (jJ. σ j = fst (σ', snd s) j)  (σ, snd (σ', snd s))  reachable A I"
         by auto
    qed
  qed

lemma subreachableE [elim]:
  assumes "subreachable A U J"
      and "s  oreachable A (λs s'. I) U"
    shows "σ. (jJ. σ j = (fst s) j)  (σ, snd s)  reachable A I"
  using assms unfolding subreachable_def by simp

lemma subreachableE_pair [elim]:
  assumes "subreachable A U J"
      and "(σ, s)  oreachable A (λs s'. I) U"
    shows "ζ. (jJ. ζ j = σ j)  (ζ, s)  reachable A I"
  using assms unfolding subreachable_def by (metis fst_conv snd_conv)

lemma subreachable_otherE [elim]:
  assumes "subreachable A U J"
      and "(σ, l)  oreachable A (λs s'. I) U"
      and "U σ σ'"
    shows "ζ'. (jJ. ζ' j = σ' j)  (ζ', l)  reachable A I"
  proof -
    from (σ, l)  oreachable A (λs s'. I) U and U σ σ'
      have "(σ', l)  oreachable A (λs s'. I) U"
      by - (rule oreachable_other')
    with ‹subreachable A U J show ?thesis
      by auto
  qed

lemma open_closed_invariant:
    fixes J
  assumes "A  (I →) P"
      and "subreachable A U J"
      and localp: "σ σ' s.  jJ. σ' j = σ j; P (σ', s)   P (σ, s)"
    shows "A  (act I, U →) P"
  proof (rule, simp_all only: act_def)
    fix s
    assume "s  init A"
    with A  (I →) P show "P s" ..
  next
    fix s a s'
    assume "s  oreachable A (λ_ _. I) U"
       and "P s"
       and "(s, a, s')  trans A"
       and "I a"
    hence "s'  oreachable A (λ_ _. I) U"
      by (metis oreachable_local)
    with ‹subreachable A U J obtain σ'
      where "jJ. σ' j = (fst s') j"
        and "(σ', snd s')  reachable A I"
        by (metis subreachableE)
    from A  (I →) P and (σ', snd s')  reachable A I have "P (σ', snd s')" ..
    with jJ. σ' j = (fst s') j show "P s'"
      by (metis localp prod.collapse)
  next
    fix g g' l
    assume or: "(g, l)  oreachable A (λs s'. I) U"
       and "U g g'"
       and "P (g, l)"
    from ‹subreachable A U J and or and U g g'
      obtain gg' where "jJ. gg' j = g' j"
                   and "(gg', l)  reachable A I"
        by (auto dest!: subreachable_otherE)
    from A  (I →) P and (gg', l)  reachable A I
      have "P (gg', l)" ..
    with jJ. gg' j = g' j show "P (g', l)"
      by (rule localp)
  qed

lemma oinvariant_anyact:
  assumes "A  (act TT, U →) P"
    shows "A  (S, U →) P"                             
  using assms by rule auto

definition
  ostep_invariant
  :: "('g × 'l, 'a) automaton
       ('g  'g  'a  bool)  ('g  'g  bool)
       (('g × 'l, 'a) transition  bool)  bool"
  ("_ A (1'((1_),/ (1_) →')/ _)" [100, 0, 0, 9] 8)
where
  "(A A (S, U →) P) =
     (soreachable A S U. (a s'. (s, a, s')  trans A  S (fst s) (fst s') a  P (s, a, s')))"

lemma ostep_invariant_def':
  "(A A (S, U →) P) = (soreachable A S U.
                           (a s'. (s, a, s')  trans A  S (fst s) (fst s') a  P (s, a, s')))"
  unfolding ostep_invariant_def by auto

lemma ostep_invariantI [intro]:
  assumes *: "σ s a σ' s'.  (σ, s)oreachable A S U; ((σ, s), a, (σ', s'))  trans A; S σ σ' a 
                              P ((σ, s), a, (σ', s'))"
    shows "A A (S, U →) P"
  unfolding ostep_invariant_def
  using assms by auto

lemma ostep_invariantD [dest]:
  assumes "A A (S, U →) P"
      and "(σ, s)oreachable A S U"
      and "((σ, s), a, (σ', s'))  trans A"
      and "S σ σ' a"
    shows "P ((σ, s), a, (σ', s'))"
  using assms unfolding ostep_invariant_def' by clarsimp

lemma ostep_invariantE [elim]:
  assumes "A A (S, U →) P"
      and "(σ, s)oreachable A S U"
      and "((σ, s), a, (σ', s'))  trans A"
      and "S σ σ' a"
      and "P ((σ, s), a, (σ', s'))  Q"
    shows "Q"
  using assms by auto

lemma ostep_invariant_weakenE [elim!]:
  assumes invP: "A A (PS, PU →) P"
      and PQ:   "t. P t  Q t"
      and QSPS: "σ σ' a. QS σ σ' a  PS σ σ' a"
      and QUPU: "σ σ'.   QU σ σ'    PU σ σ'"
    shows       "A A (QS, QU →) Q"
  proof
    fix σ s σ' s' a
    assume "(σ, s)  oreachable A QS QU"
       and "((σ, s), a, (σ', s'))  trans A"
       and "QS σ σ' a"
    from QS σ σ' a have "PS σ σ' a" by (rule QSPS)
    from (σ, s)  oreachable A QS QU have "(σ, s)  oreachable A PS PU" using QSPS QUPU ..
    with invP have "P ((σ, s), a, (σ', s'))" using ((σ, s), a, (σ', s'))  trans A PS σ σ' a ..
    thus "Q ((σ, s), a, (σ', s'))" by (rule PQ)
  qed

lemma ostep_invariant_weaken_with_invariantE [elim]:
  assumes pinv: "A  (S, U →) P"
      and qinv: "A A (S, U →) Q"
      and wr: "σ s a σ' s'.  P (σ, s); P (σ', s'); Q ((σ, s), a, (σ', s')); S σ σ' a 
                               R ((σ, s), a, (σ', s'))"
    shows "A A (S, U →) R"
  proof
    fix σ s a σ' s'
    assume sr: "(σ, s)  oreachable A S U"
       and tr: "((σ, s), a, (σ', s'))  trans A"
       and "S σ σ' a"
    hence "(σ', s')  oreachable A S U" ..
    with pinv have "P (σ', s')" ..
    from pinv and sr have "P (σ, s)" ..
    from qinv sr tr S σ σ' a have "Q ((σ, s), a, (σ', s'))" ..
    with P (σ, s) and P (σ', s') show "R ((σ, s), a, (σ', s'))" using S σ σ' a by (rule wr)
  qed

lemma ostep_to_invariantI:
  assumes sinv: "A A (S, U →) Q"
      and init: "σ s. (σ, s)  init A  P (σ, s)"
      and local: "σ s σ' s' a.
                     (σ, s)  oreachable A S U;
                      P (σ, s);
                      Q ((σ, s), a, (σ', s'));
                      S σ σ' a   P (σ', s')"
      and other: "σ σ' s.  (σ, s)  oreachable A S U; U σ σ'; P (σ, s)   P (σ', s)"
    shows "A  (S, U →) P"
  proof
    fix σ s assume "(σ, s)  init A" thus "P (σ, s)" by (rule init)
  next
    fix σ s σ' s' a
    assume "(σ, s)  oreachable A S U"
       and "P (σ, s)"
       and "((σ, s), a, (σ', s'))  trans A"
       and "S σ σ' a"
      show "P (σ', s')"
    proof -
      from sinv and (σ, s)oreachable A S U and ((σ, s), a, (σ', s'))  trans A and S σ σ' a
        have "Q ((σ, s), a, (σ', s'))" ..
      with (σ, s)oreachable A S U and P (σ, s) show "P (σ', s')"
        using S σ σ' a by (rule local)
    qed
  next
    fix σ σ' l
    assume "(σ, l)  oreachable A S U"
       and "U σ σ'"
       and "P (σ, l)"
      thus "P (σ', l)" by (rule other)
  qed

lemma open_closed_step_invariant:
  assumes "A A (I →) P"
      and "local_steps (trans A) J"
      and "other_steps U J"
      and localp: "σ ζ a σ' ζ' s s'.
                    jJ. σ j = ζ j; jJ. σ' j = ζ' j; P ((σ, s), a, (σ', s')) 
                    P ((ζ, s), a, (ζ', s'))"
    shows "A A (act I, U →) P"
  proof
    fix σ s a σ' s'
    assume or: "(σ, s)  oreachable A (act I) U"
       and tr: "((σ, s), a, (σ', s'))  trans A"
       and "act I σ σ' a"
    from ‹act I σ σ' a have "I a" ..
    from ‹local_steps (trans A) J and ‹other_steps U J have "subreachable A U J" ..
    then obtain ζ where "jJ. ζ j = σ j"
                    and "(ζ, s)  reachable A I"
      using or unfolding act_def
        by (auto dest!: subreachableE_pair)

     from ‹local_steps (trans A) J and tr and jJ. ζ j = σ j
       obtain ζ' where "jJ. ζ' j = σ' j"
                   and "((ζ, s), a, (ζ', s'))  trans A"
       by auto

    from A A (I →) P and (ζ, s)  reachable A I
                          and ((ζ, s), a, (ζ', s'))  trans A
                          and I a
      have "P ((ζ, s), a, (ζ', s'))" ..
    with jJ. ζ j = σ j and jJ. ζ' j = σ' j show "P ((σ, s), a, (σ', s'))"
      by (rule localp)
  qed

lemma oinvariant_step_anyact:
  assumes "p A (act TT, U →) P"
    shows "p A (S, U →) P"
  using assms by rule auto

subsection "Standard assumption predicates "

text ‹otherwith›

definition otherwith :: "('s  's  bool)
                           'i set
                           (('i  's)  'a  bool)
                           ('i  's)  ('i  's)  'a  bool"
where "otherwith Q I P σ σ' a  (i. iI  Q (σ i) (σ' i))  P σ a"

lemma otherwithI [intro]:
  assumes other: "j. jI  Q (σ j) (σ' j)"
      and sync:  "P σ a"
    shows "otherwith Q I P σ σ' a"
  unfolding otherwith_def using assms by simp

lemma otherwithE [elim]:
  assumes "otherwith Q I P σ σ' a"
      and " P σ a; j. jI  Q (σ j) (σ' j)   R σ σ' a"
    shows "R σ σ' a"
  using assms unfolding otherwith_def by simp

lemma otherwith_actionD [dest]:
  assumes "otherwith Q I P σ σ' a"
    shows "P σ a"
  using assms by auto

lemma otherwith_syncD [dest]:
  assumes "otherwith Q I P σ σ' a"
    shows "j. jI  Q (σ j) (σ' j)"
  using assms by auto

lemma otherwithEI [elim]:
  assumes "otherwith P I PO σ σ' a"
      and "σ a. PO σ a  QO σ a"
    shows "otherwith P I QO σ σ' a"
  using assms(1) unfolding otherwith_def
  by (clarsimp elim!: assms(2))

lemma all_but:
  assumes "ξ. S ξ ξ"
      and "σ' i = σ i"
      and "j. j  i  S (σ j) (σ' j)"
    shows "j. S (σ j) (σ' j)"
  using assms by metis

lemma all_but_eq [dest]:
  assumes "σ' i = σ i"
      and "j. j  i  σ j = σ' j"
    shows "σ = σ'"
  using assms by - (rule ext, metis)

text ‹other›

definition other :: "('s  's  bool)  'i set  ('i  's)  ('i  's)  bool"
where "other P I σ σ'  i. if iI then σ' i = σ i else P (σ i) (σ' i)"

lemma otherI [intro]:
  assumes local: "i. iI  σ' i = σ i"
      and other: "j. jI  P (σ j) (σ' j)"
    shows "other P I σ σ'"
  using assms unfolding other_def by clarsimp

lemma otherE [elim]:
  assumes "other P I σ σ'"
      and " iI. σ' i = σ i; j. jI  P (σ j) (σ' j)   R σ σ'"
    shows "R σ σ'"
  using assms unfolding other_def by simp

lemma other_localD [dest]:
  "other P {i} σ σ'  σ' i = σ i"
  by auto

lemma other_otherD [dest]:
  "other P {i} σ σ'  j. ji  P (σ j) (σ' j)"
  by auto

lemma other_bothE [elim]:
  assumes "other P {i} σ σ'"
  obtains "σ' i = σ i" and "j. ji  P (σ j) (σ' j)"
  using assms by auto

lemma weaken_local [elim]:
  assumes "other P I σ σ'"
      and PQ: "ξ ξ'. P ξ ξ'  Q ξ ξ'"
    shows "other Q I σ σ'"
  using assms unfolding other_def by auto

definition global :: "((nat  's)  bool)  (nat  's) × 'local  bool"
where "global P  (λ(σ, _). P σ)"

lemma globalsimp [simp]: "global P s = P (fst s)"
  unfolding global_def by (simp split: prod.split)

definition globala :: "((nat  's, 'action) transition  bool)
                        ((nat  's) × 'local, 'action) transition  bool"
where "globala P  (λ((σ, _), a, (σ', _)). P (σ, a, σ'))"

lemma globalasimp [simp]: "globala P s = P (fst (fst s), fst (snd s), fst (snd (snd s)))"
  unfolding globala_def by (simp split: prod.split)

end

Theory AWN

(*  Title:       AWN.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Terms of the Algebra for Wireless Networks"

theory AWN
imports Lib
begin

subsection "Sequential Processes"

type_synonym ip = nat
type_synonym data = nat

text ‹
  Most of AWN is independent of the type of messages, but the closed layer turns
  newpkt actions into the arrival of newpkt messages. We use a type class to maintain
  some abstraction (and independence from the definition of particular protocols).
›

class msg =
  fixes newpkt :: "data × ip  'a"
    and eq_newpkt :: "'a  bool"
  assumes eq_newpkt_eq [simp]: "eq_newpkt (newpkt (d, i))"

text ‹
  Sequential process terms abstract over the types of data states (@{typ 's}),
  messages (@{typ 'm}), process names (@{typ 'p}),and labels (@{typ 'l}).
›

datatype (dead 's, dead 'm, dead 'p, 'l) seqp =
    GUARD "'l" "'s  's set" "('s, 'm, 'p, 'l) seqp"
  | ASSIGN "'l" "'s  's" "('s, 'm, 'p, 'l) seqp"
  | CHOICE "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
  | UCAST "'l" "'s  ip" "'s  'm" "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
  | BCAST "'l" "'s  'm" "('s, 'm, 'p, 'l) seqp"
  | GCAST "'l" "'s  ip set" "'s  'm" "('s, 'm, 'p, 'l) seqp"
  | SEND "'l" "'s  'm" "('s, 'm, 'p, 'l) seqp"
  | DELIVER "'l" "'s  data" "('s, 'm, 'p, 'l) seqp"
  | RECEIVE "'l" "'m  's  's" "('s, 'm, 'p, 'l) seqp"
  | CALL 'p
  for map: labelmap

syntax
  "_guard"    :: "['a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(‹unbreakable›_)//_" [0, 60] 60)
  "_lguard"   :: "['a, 'a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("{_}(‹unbreakable›_)//_" [0, 0, 60] 60)
  "_ifguard"  :: "[pttrn, bool,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(‹unbreakable›_. _)//_" [0, 0, 60] 60)

  "_bassign"  :: "[pttrn, 'a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(‹unbreakable›_. _)//_" [0, 0, 60] 60)
  "_lbassign" :: "['a, pttrn, 'a, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("{_}(‹unbreakable›_. _)//_" [0, 0, 0, 60] 60)

  "_assign"  :: "['a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("((‹unbreakable›_))//_" [0, 60] 60)
  "_lassign" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("({_}(‹unbreakable›_))//_" [0, 0, 60] 60)

  "_unicast"  :: "['a, 'a,  ('s, 'm, 'p, unit) seqp,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(3unicast'((1(3_),/ (3_))') .//(_)/ (2 _))" [0, 0, 60, 60] 60)
  "_lunicast" :: "['a, 'a, 'a, ('s, 'm, 'p, 'a) seqp, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}unicast'((1(3_),/ (3_))') .//(_)/ (2 _))" [0, 0, 0, 60, 60] 60)

  "_bcast"    :: "['a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(3broadcast'((1(_))') .)//_" [0, 60] 60)
  "_lbcast"   :: "['a, 'a, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}broadcast'((1(_))') .)//_" [0, 0, 60] 60)

  "_gcast"    :: "['a, 'a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(3groupcast'((1(_),/ (_))') .)//_" [0, 0, 60] 60)
  "_lgcast"   :: "['a, 'a, 'a, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}groupcast'((1(_),/ (_))') .)//_" [0, 0, 0, 60] 60)

  "_send"     :: "['a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(3send'((_)') .)//_" [0, 60] 60)
  "_lsend"    :: "['a, 'a, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}send'((_)') .)//_" [0, 0, 60] 60)

  "_deliver"  :: "['a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(3deliver'((_)') .)//_" [0, 60] 60)
  "_ldeliver" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}deliver'((_)') .)//_" [0, 0, 60] 60)

  "_receive"  :: "['a,  ('s, 'm, 'p, unit) seqp]   ('s, 'm, 'p, unit) seqp"
                 ("(3receive'((_)') .)//_" [0, 60] 60)
  "_lreceive" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp]  ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}receive'((_)') .)//_" [0, 0, 60] 60)

translations
  "_guard f p"      "CONST GUARD () f p"
  "_lguard l f p"   "CONST GUARD l f p"
  "_ifguard ξ e p"  "CONST GUARD () (λξ. if e then {ξ} else {}) p"

  "_assign f p"     "CONST ASSIGN () f p"
  "_lassign l f p"  "CONST ASSIGN l f p"

  "_bassign ξ e p"     "CONST ASSIGN () (λξ. e) p"
  "_lbassign l ξ e p"  "CONST ASSIGN l (λξ. e) p"

  "_unicast fip fmsg p q"     "CONST UCAST () fip fmsg p q"
  "_lunicast l fip fmsg p q"  "CONST UCAST l fip fmsg p q"

  "_bcast fmsg p"     "CONST BCAST () fmsg p"
  "_lbcast l fmsg p"  "CONST BCAST l fmsg p"

  "_gcast fipset fmsg p"     "CONST GCAST () fipset fmsg p"
  "_lgcast l fipset fmsg p"  "CONST GCAST l fipset fmsg p"

  "_send fmsg p"     "CONST SEND () fmsg p"
  "_lsend l fmsg p"  "CONST SEND l fmsg p"

  "_deliver fdata p"     "CONST DELIVER () fdata p"
  "_ldeliver l fdata p"  "CONST DELIVER l fdata p"

  "_receive fmsg p"     "CONST RECEIVE () fmsg p"
  "_lreceive l fmsg p"  "CONST RECEIVE l fmsg p"

notation "CHOICE" ("((_)////(_))" [56, 55] 55)
     and "CALL"   ("(3call'((3_)'))" [0] 60)

definition not_call :: "('s, 'm, 'p, 'l) seqp  bool"
where "not_call p  pn. p  call(pn)"

lemma not_call_simps [simp]:
  "l fg p.         not_call ({l}fg p)"
  "l fa p.         not_call ({l}fa p)"
  "p1 p2.          not_call (p1  p2)"
  "l fip fmsg p q. not_call ({l}unicast(fip, fmsg).p  q)"
  "l fmsg p.       not_call ({l}broadcast(fmsg).p)"
  "l fips fmsg p.  not_call ({l}groupcast(fips, fmsg).p)"
  "l fmsg p.       not_call ({l}send(fmsg).p)"
  "l fdata p.      not_call ({l}deliver(fdata).p)"
  "l fmsg p.       not_call ({l}receive(fmsg).p)"
  "l pn.         ¬(not_call (call(pn)))"
  unfolding not_call_def by auto

definition not_choice :: "('s, 'm, 'p, 'l) seqp  bool"
where "not_choice p  p1 p2. p  p1  p2"

lemma not_choice_simps [simp]:
  "l fg p.         not_choice ({l}fg p)"
  "l fa p.         not_choice ({l}fa p)"
  "p1 p2.        ¬(not_choice (p1  p2))"
  "l fip fmsg p q. not_choice ({l}unicast(fip, fmsg).p  q)"
  "l fmsg p.       not_choice ({l}broadcast(fmsg).p)"
  "l fips fmsg p.  not_choice ({l}groupcast(fips, fmsg).p)"
  "l fmsg p.       not_choice ({l}send(fmsg).p)"
  "l fdata p.      not_choice ({l}deliver(fdata).p)"
  "l fmsg p.       not_choice ({l}receive(fmsg).p)"
  "l pn.           not_choice (call(pn))"
  unfolding not_choice_def by auto

lemma seqp_congs:
  "l fg p. {l}fg p = {l}fg p"
  "l fa p. {l}fa p = {l}fa p"
  "p1 p2. p1  p2 = p1  p2"
  "l fip fmsg p q. {l}unicast(fip, fmsg).p  q = {l}unicast(fip, fmsg).p  q"
  "l fmsg p. {l}broadcast(fmsg).p = {l}broadcast(fmsg).p"
  "l fips fmsg p. {l}groupcast(fips, fmsg).p = {l}groupcast(fips, fmsg).p"
  "l fmsg p. {l}send(fmsg).p = {l}send(fmsg).p"
  "l fdata p. {l}deliver(fdata).p = {l}deliver(fdata).p"
  "l fmsg p. {l}receive(fmsg).p = {l}receive(fmsg).p"
  "l pn. call(pn) = call(pn)"
  by auto

text ‹Remove data expressions from process terms.›

fun seqp_skeleton :: "('s, 'm, 'p, 'l) seqp  (unit, unit, 'p, 'l) seqp"
where
    "seqp_skeleton ({l}_ p)                 = {l}λ_. {()} (seqp_skeleton p)"
  | "seqp_skeleton ({l}_ p)                 = {l}λ_. () (seqp_skeleton p)"
  | "seqp_skeleton (p  q)                   = (seqp_skeleton p)  (seqp_skeleton q)"
  | "seqp_skeleton ({l}unicast(_, _). p  q) = {l}unicast(λ_. 0, λ_. ()). (seqp_skeleton p)  (seqp_skeleton q)"
  | "seqp_skeleton ({l}broadcast(_). p)      = {l}broadcast(λ_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}groupcast(_, _). p)   = {l}groupcast(λ_. {}, λ_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}send(_). p)           = {l}send(λ_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}deliver(_). p)        = {l}deliver(λ_. 0). (seqp_skeleton p)"
  | "seqp_skeleton ({l}receive(_). p)        = {l}receive(λ_ _. ()). (seqp_skeleton p)"
  | "seqp_skeleton (call(pn))                = call(pn)"

text ‹Calculate the subterms of a term.›

fun subterms :: "('s, 'm, 'p, 'l) seqp  ('s, 'm, 'p, 'l) seqp set"
where
    "subterms ({l}fg p) = {{l}fg p}  subterms p"
  | "subterms ({l}fa p) = {{l}fa p}  subterms p"
  | "subterms (p1  p2) = {p1  p2}  subterms p1  subterms p2"
  | "subterms ({l}unicast(fip, fmsg). p  q) =
       {{l}unicast(fip, fmsg). p  q}  subterms p  subterms q"
  | "subterms ({l}broadcast(fmsg). p) = {{l}broadcast(fmsg). p}  subterms p"
  | "subterms ({l}groupcast(fips, fmsg). p) = {{l}groupcast(fips, fmsg). p}  subterms p"
  | "subterms ({l}send(fmsg). p) = {{l}send(fmsg).p}  subterms p"
  | "subterms ({l}deliver(fdata). p) = {{l}deliver(fdata).p}  subterms p"
  | "subterms ({l}receive(fmsg). p) = {{l}receive(fmsg).p}  subterms p"
  | "subterms (call(pn)) = {call(pn)}"

lemma subterms_refl [simp]: "p  subterms p"
  by (cases p) simp_all

lemma subterms_trans [elim]:
  assumes "q  subterms p"
      and "r  subterms q"
    shows "r  subterms p"
  using assms by (induction p) auto

lemma root_in_subterms [simp]:
   "Γ pn. pn'. Γ pn  subterms (Γ pn')"
  by (rule_tac x=pn in exI) simp

lemma deriv_in_subterms [elim, dest]:
  "l f p q. {l}f q  subterms p  q  subterms p"
  "l fa p q. {l}fa q  subterms p  q  subterms p"
  "p1 p2 p. p1  p2  subterms p  p1  subterms p"
  "p1 p2 p. p1  p2  subterms p  p2  subterms p"
  "l fip fmsg p q r. {l}unicast(fip, fmsg). q  r  subterms p  q  subterms p"
  "l fip fmsg p q r. {l}unicast(fip, fmsg). q  r  subterms p  r  subterms p"
  "l fmsg p q. {l}broadcast(fmsg). q  subterms p  q  subterms p"
  "l fips fmsg p q. {l}groupcast(fips, fmsg). q  subterms p  q  subterms p"
  "l fmsg p q. {l}send(fmsg). q  subterms p  q  subterms p"
  "l fdata p q. {l}deliver(fdata). q  subterms p  q  subterms p"
  "l fmsg p q. {l}receive(fmsg). q  subterms p  q  subterms p"
  by auto

subsection "Actions"

text ‹
  There are two sorts of τ› actions in AWN: one at the level of individual processes
  (within nodes), and one at the network level (outside nodes). We define a class so that
  we can ignore this distinction whenever it is not critical.
›

class tau =
  fixes tau :: "'a" ("τ")

subsubsection "Sequential Actions (and related predicates)"

datatype 'm seq_action =
    broadcast 'm
  | groupcast "ip set" 'm
  | unicast ip 'm
  | notunicast ip           ("¬unicast _" [1000] 60)
  | send 'm
  | deliver data
  | receive 'm
  | seq_tau                 ("τs")

instantiation "seq_action" :: (type) tau
begin
definition step_seq_tau [simp]: "τ  τs"
instance ..
end

definition recvmsg :: "('m  bool)  'm seq_action  bool"
where "recvmsg P a  case a of receive m  P m
                             | _  True"

lemma recvmsg_simps[simp]:
  "m.     recvmsg P (broadcast m)     = True"
  "ips m. recvmsg P (groupcast ips m) = True"
  "ip m.  recvmsg P (unicast ip m)    = True"
  "ip.    recvmsg P (notunicast ip)   = True"
  "m.     recvmsg P (send m)          = True"
  "d.     recvmsg P (deliver d)       = True"
  "m.     recvmsg P (receive m)       = P m"
  "        recvmsg P τs                 = True"
  unfolding recvmsg_def by simp_all

lemma recvmsgTT [simp]: "recvmsg TT a"
  by (cases a) simp_all

lemma recvmsgE [elim]:
  assumes "recvmsg (R σ) a"
      and "m. R σ m  R σ' m"
    shows "recvmsg (R σ') a"
  using assms(1) by (cases a) (auto elim!: assms(2))

definition anycast :: "('m  bool)  'm seq_action  bool"
where "anycast P a  case a of broadcast m  P m
                             | groupcast _ m  P m
                             | unicast _ m  P m
                             | _  True"

lemma anycast_simps [simp]:
  "m.     anycast P (broadcast m)     = P m"
  "ips m. anycast P (groupcast ips m) = P m"
  "ip m.  anycast P (unicast ip m)    = P m"
  "ip.    anycast P (notunicast ip)   = True"
  "m.     anycast P (send m)          = True"
  "d.     anycast P (deliver d)       = True"
  "m.     anycast P (receive m)       = True"
  "        anycast P τs                 = True"
  unfolding anycast_def by simp_all

definition orecvmsg :: "((ip  's)  'm  bool)  (ip  's)  'm seq_action  bool"
where "orecvmsg P σ a  (case a of receive m  P σ m
                                         | _  True)"

lemma orecvmsg_simps [simp]:
  "m.     orecvmsg P σ (broadcast m)     = True"
  "ips m. orecvmsg P σ (groupcast ips m) = True"
  "ip m.  orecvmsg P σ (unicast ip m)    = True"
  "ip.    orecvmsg P σ (notunicast ip)   = True"
  "m.     orecvmsg P σ (send m)          = True"
  "d.     orecvmsg P σ (deliver d)       = True"
  "m.     orecvmsg P σ (receive m)       = P σ m"
  "         orecvmsg P σ τs                = True"
  unfolding orecvmsg_def by simp_all

lemma orecvmsgEI [elim]:
  " orecvmsg P σ a; σ a. P σ a  Q σ a   orecvmsg Q σ a"
  by (cases a) simp_all

lemma orecvmsg_stateless_recvmsg [elim]:
  "orecvmsg (λ_. P) σ a  recvmsg P a"
  by (cases a) simp_all

lemma orecvmsg_recv_weaken [elim]:
  " orecvmsg P σ a; σ a. P σ a  Q a   recvmsg Q a"
  by (cases a) simp_all

lemma orecvmsg_recvmsg [elim]:
  "orecvmsg P σ a  recvmsg (P σ) a"
  by (cases a) simp_all

definition sendmsg :: "('m  bool)  'm seq_action  bool"
where "sendmsg P a  case a of send m  P m | _  True"

lemma sendmsg_simps [simp]:
  "m.     sendmsg P (broadcast m)     = True"
  "ips m. sendmsg P (groupcast ips m) = True"
  "ip m.  sendmsg P (unicast ip m)    = True"
  "ip.    sendmsg P (notunicast ip)   = True"
  "m.     sendmsg P (send m)          = P m"
  "d.     sendmsg P (deliver d)       = True"
  "m.     sendmsg P (receive m)       = True"
  "        sendmsg P τs                 = True"
  unfolding sendmsg_def by simp_all

type_synonym ('s, 'm, 'p, 'l) seqp_env = "'p  ('s, 'm, 'p, 'l) seqp"

subsubsection "Node Actions (and related predicates)"

datatype 'm node_action =
    node_cast "ip set" 'm             ("_:*cast'(_')"       [200, 200] 200)                                                 
  | node_deliver ip data              ("_:deliver'(_')"     [200, 200] 200)
  | node_arrive "ip set" "ip set" 'm  ("_¬_:arrive'(_')"    [200, 200, 200] 200)
  | node_connect ip ip                ("connect'(_, _')"    [200, 200] 200)
  | node_disconnect ip ip             ("disconnect'(_, _')" [200, 200] 200)
  | node_newpkt ip data ip            ("_:newpkt'(_, _')"   [200, 200, 200] 200)
  | node_tau                          ("τn")

instantiation "node_action" :: (type) tau
begin
definition step_node_tau [simp]: "τ  τn"
instance ..
end

definition arrivemsg :: "ip  ('m  bool)  'm node_action  bool"
where "arrivemsg i P a  case a of node_arrive ii ni m  ((ii = {i}  P m))
                                  | _  True"

lemma arrivemsg_simps[simp]:
  "R m.       arrivemsg i P (R:*cast(m))         = True"
  "d m.       arrivemsg i P (d:deliver(m))       = True"
  "i ii ni m. arrivemsg i P (ii¬ni:arrive(m))    = (ii = {i}  P m)"
  "i1 i2.     arrivemsg i P (connect(i1, i2))    = True"
  "i1 i2.     arrivemsg i P (disconnect(i1, i2)) = True"
  "i i' d di. arrivemsg i P (i':newpkt(d, di))   = True"
  "             arrivemsg i P τn                   = True"
  unfolding arrivemsg_def by simp_all

lemma arrivemsgTT [simp]: "arrivemsg i TT = TT"
  by (rule ext) (clarsimp simp: arrivemsg_def split: node_action.split)

definition oarrivemsg :: "((ip  's)  'm  bool)  (ip  's)  'm node_action  bool"
where "oarrivemsg P σ a  case a of node_arrive ii ni m  P σ m | _  True"

lemma oarrivemsg_simps[simp]:
  "R m.       oarrivemsg P σ (R:*cast(m))         = True"
  "d m.       oarrivemsg P σ (d:deliver(m))       = True"
  "i ii ni m. oarrivemsg P σ (ii¬ni:arrive(m))    = P σ m"
  "i1 i2.     oarrivemsg P σ (connect(i1, i2))    = True"
  "i1 i2.     oarrivemsg P σ (disconnect(i1, i2)) = True"
  "i i' d di. oarrivemsg P σ (i':newpkt(d, di))   = True"
  "             oarrivemsg P σ τn                   = True"
  unfolding oarrivemsg_def by simp_all

lemma oarrivemsg_True [simp, intro]: "oarrivemsg (λ_ _. True) σ a"
  by (cases a) auto

definition castmsg :: "('m  bool)  'm node_action  bool"
where "castmsg P a  case a of _:*cast(m)  P m
                              | _  True"

lemma castmsg_simps[simp]:
  "R m.       castmsg P (R:*cast(m))         = P m"
  "d m.       castmsg P (d:deliver(m))       = True"
  "i ii ni m. castmsg P (ii¬ni:arrive(m))    = True"
  "i1 i2.     castmsg P (connect(i1, i2))    = True"
  "i1 i2.     castmsg P (disconnect(i1, i2)) = True"
  "i i' d di. castmsg P (i':newpkt(d, di))   = True"
  "             castmsg P τn                   = True"
  unfolding castmsg_def by simp_all

subsection "Networks"

datatype net_tree =
    Node ip "ip set"          ("_; _")
  | Subnet net_tree net_tree  (infixl "" 90)

declare net_tree.induct [[induct del]]
lemmas net_tree_induct [induct type: net_tree] = net_tree.induct [rename_abs i R p1 p2]

datatype 's net_state =
    NodeS ip 's "ip set"
  | SubnetS "'s net_state" "'s net_state"

fun net_ips :: "'s net_state  ip set"
where
    "net_ips (NodeS i s R) = {i}"
  | "net_ips (SubnetS n1 n2) = net_ips n1  net_ips n2"

fun net_tree_ips :: "net_tree  ip set"
where
    "net_tree_ips (p1  p2) = net_tree_ips p1  net_tree_ips p2"
  | "net_tree_ips (i; R) = {i}"

lemma net_tree_ips_commute:
  "net_tree_ips (p1  p2) = net_tree_ips (p2  p1)"
  by simp (rule Un_commute)

fun wf_net_tree :: "net_tree  bool"
where
   "wf_net_tree (p1  p2) = (net_tree_ips p1  net_tree_ips p2 = {}
                              wf_net_tree p1  wf_net_tree p2)"
 | "wf_net_tree (i; R) = True"

lemma wf_net_tree_children [elim]:
  assumes "wf_net_tree (p1  p2)"
  obtains "wf_net_tree p1"
      and "wf_net_tree p2"
  using assms by simp

fun netmap :: "'s net_state  ip  's option"
where
    "netmap (NodeS i p Ri) = [i  p]"
  | "netmap (SubnetS s t) = netmap s ++ netmap t"

lemma not_in_netmap [simp]:
  assumes "i  net_ips ns"
    shows "netmap ns i = None"
  using assms by (induction ns) simp_all

lemma netmap_none_not_in_net_ips:
  assumes "netmap ns i = None"
    shows "inet_ips ns"
  using assms by (induction ns) auto

lemma net_ips_is_dom_netmap: "net_ips s = dom(netmap s)"
  proof (induction s)
    fix i Ri and p :: 's
    show "net_ips (NodeS i p Ri) = dom (netmap (NodeS i p Ri))"
      by auto
  next
    fix s1 s2 :: "'s net_state"
    assume "net_ips s1 = dom (netmap s1)"
       and "net_ips s2 = dom (netmap s2)"
    thus "net_ips (SubnetS s1 s2) = dom (netmap (SubnetS s1 s2))"
      by auto
  qed

lemma in_netmap [simp]:
  assumes "i  net_ips ns"
    shows "netmap ns i  None"
  using assms by (auto simp add: net_ips_is_dom_netmap)

lemma netmap_subnets_same:
  assumes "netmap s1 i = x"
      and "netmap s2 i = x"
    shows "netmap (SubnetS s1 s2) i = x"
  using assms by simp (metis map_add_dom_app_simps(1) map_add_dom_app_simps(3))

lemma netmap_subnets_samef:
  assumes "netmap s1 = f"
      and "netmap s2 = f"
    shows "netmap (SubnetS s1 s2) = f"
  using assms by simp (metis map_add_le_mapI map_le_antisym map_le_map_add map_le_refl)

lemma netmap_add_disjoint [elim]:
  assumes "inet_ips s1  net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i"
      and "net_ips s1  net_ips s2 = {}"
    shows "inet_ips s1. the (netmap s1 i) = σ i"
  proof
    fix i
    assume "i  net_ips s1"
    hence "i  dom(netmap s1)" by (simp add: net_ips_is_dom_netmap)
    moreover with assms(2) have "i  dom(netmap s2)" by (auto simp add: net_ips_is_dom_netmap)
    ultimately have "the (netmap s1 i) = the ((netmap s1 ++ netmap s2) i)"
      by (simp add: map_add_dom_app_simps)
    with assms(1) and inet_ips s1 show "the (netmap s1 i) = σ i" by simp
  qed

lemma netmap_add_disjoint2 [elim]:
  assumes "inet_ips s1  net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i"
    shows "inet_ips s2. the (netmap s2 i) = σ i"
  using assms by (simp add: net_ips_is_dom_netmap)
                 (metis Un_iff map_add_dom_app_simps(1))

lemma net_ips_netmap_subnet [elim]:
  assumes "net_ips s1  net_ips s2 = {}"
      and "inet_ips (SubnetS s1 s2). the (netmap (SubnetS s1 s2) i) = σ i"
    shows "inet_ips s1. the (netmap s1 i) = σ i"
      and "inet_ips s2. the (netmap s2 i) = σ i"
  proof -
    from assms(2) have "inet_ips s1  net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i" by auto
    with assms(1) show "inet_ips s1. the (netmap s1 i) = σ i"
      by - (erule(1) netmap_add_disjoint)
  next
    from assms(2) have "inet_ips s1  net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i" by auto
    thus "inet_ips s2. the (netmap s2 i) = σ i"
      by - (erule netmap_add_disjoint2)
  qed

fun inoclosed :: "'s  'm::msg node_action  bool"
where
    "inoclosed _ (node_arrive ii ni m) = eq_newpkt m"
  | "inoclosed _ (node_newpkt i d di)  = False"
  | "inoclosed _ _ = True"

lemma inclosed_simps [simp]:
  "σ ii ni. inoclosed σ (ii¬ni:arrive(m))   = eq_newpkt m"
  "σ d di.  inoclosed σ (i:newpkt(d, di))   = False"
  "σ R m.   inoclosed σ (R:*cast(m))        = True"
  "σ i d.   inoclosed σ (i:deliver(d))      = True"
  "σ i i'.  inoclosed σ (connect(i, i'))    = True"
  "σ i i'.  inoclosed σ (disconnect(i, i')) = True"
  "σ.       inoclosed σ (τ)                 = True"
  by auto

definition
  netmask :: "ip set  ((ip  's) × 'l)  ((ip  's option) × 'l)"
where
  "netmask I s  (λi. if iI then Some (fst s i) else None, snd s)"

lemma netmask_def' [simp]:
  "netmask I (σ, ζ) = (λi. if iI then Some (σ i) else None, ζ)"
  unfolding netmask_def by auto

fun netgmap :: "('s  'g × 'l)  's net_state  (nat  'g option) × 'l net_state"
  where
    "netgmap sr (NodeS i s R) = ([i  fst (sr s)], NodeS i (snd (sr s)) R)"
  | "netgmap sr (SubnetS s1 s2) = (let (σ1, ss) = netgmap sr s1 in
                                   let (σ2, tt) = netgmap sr s2 in
                                   (σ1 ++ σ2, SubnetS ss tt))"

lemma dom_fst_netgmap [simp, intro]: "dom (fst (netgmap sr n)) = net_ips n"
  proof (induction n)
    fix i s R
    show "dom (fst (netgmap sr (NodeS i s R))) = net_ips (NodeS i s R)"
      by simp
  next
    fix n1 n2
    assume a1: "dom (fst (netgmap sr n1)) = net_ips n1"
       and a2: "dom (fst (netgmap sr n2)) = net_ips n2"
    obtain σ1 ζ1 σ2 ζ2 where nm1: "netgmap sr n1 = (σ1, ζ1)"
                        and nm2: "netgmap sr n2 = (σ2, ζ2)"
      by (metis surj_pair)
    hence "netgmap sr (SubnetS n1 n2) = (σ1 ++ σ2, SubnetS ζ1 ζ2)" by simp
    hence "dom (fst (netgmap sr (SubnetS n1 n2))) = dom (σ1 ++ σ2)" by simp
    also from a1 a2 nm1 nm2 have "dom (σ1 ++ σ2) = net_ips (SubnetS n1 n2)" by auto
    finally show "dom (fst (netgmap sr (SubnetS n1 n2))) = net_ips (SubnetS n1 n2)" .
  qed

lemma netgmap_pair_dom [elim]:
  obtains σ ζ where "netgmap sr n = (σ, ζ)"
                and "dom σ = net_ips n"
    by (metis dom_fst_netgmap surjective_pairing)

lemma net_ips_netgmap [simp]:
  "net_ips (snd (netgmap sr s)) = net_ips s"
  proof (induction s)
    fix s1 s2
    assume "net_ips (snd (netgmap sr s1)) = net_ips s1"
       and "net_ips (snd (netgmap sr s2)) = net_ips s2"
    thus "net_ips (snd (netgmap sr (SubnetS s1 s2))) = net_ips (SubnetS s1 s2)"
      by (cases "netgmap sr s1", cases "netgmap sr s2") auto
  qed simp

lemma some_the_fst_netgmap:
  assumes "i  net_ips s"
    shows "Some (the (fst (netgmap sr s) i)) = fst (netgmap sr s) i"
  using assms by (metis domIff dom_fst_netgmap option.collapse)


lemma fst_netgmap_none [simp]:
  assumes "i  net_ips s"
    shows "fst (netgmap sr s) i = None"
  using assms by (metis domIff dom_fst_netgmap)

lemma fst_netgmap_subnet [simp]:
  "fst (case netgmap sr s1 of (σ1, ss) 
        case netgmap sr s2 of (σ2, tt) 
        (σ1 ++ σ2, SubnetS ss tt)) = (fst (netgmap sr s1) ++ fst (netgmap sr s2))"
  by (metis (mono_tags) fst_conv netgmap_pair_dom split_conv)

lemma snd_netgmap_subnet [simp]:
  "snd (case netgmap sr s1 of (σ1, ss) 
        case netgmap sr s2 of (σ2, tt) 
        (σ1 ++ σ2, SubnetS ss tt)) = (SubnetS (snd (netgmap sr s1)) (snd (netgmap sr s2)))"
  by (metis (lifting, no_types) Pair_inject split_beta' surjective_pairing)

lemma fst_netgmap_not_none [simp]:
  assumes "i  net_ips s"
    shows "fst (netgmap sr s) i  None"
  using assms by (induction s) auto

lemma netgmap_netgmap_not_rhs [simp]:
  assumes "i  net_ips s2"
    shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s1)) i"
  proof -
    from assms(1) have "i  dom (fst (netgmap sr s2))" by simp
    thus ?thesis by (simp add: map_add_dom_app_simps)
  qed

lemma netgmap_netgmap_rhs [simp]:
  assumes "i  net_ips s2"
    shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s2)) i"
  using assms by (simp add: map_add_dom_app_simps)

lemma netgmap_netmask_subnets [elim]:
  assumes "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
      and "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
    shows "fst (netgmap sr (SubnetS s1 s2))
            = fst (netmask (net_tree_ips (n1  n2)) (σ, snd (netgmap sr (SubnetS s1 s2))))"
  proof (rule ext)
    fix i
    have "i  net_tree_ips n1  i  net_tree_ips n2  (inet_tree_ips n1  net_tree_ips n2)"
      by auto
    thus "fst (netgmap sr (SubnetS s1 s2)) i
            = fst (netmask (net_tree_ips (n1  n2)) (σ, snd (netgmap sr (SubnetS s1 s2)))) i"
    proof (elim disjE)
      assume "i  net_tree_ips n1"
      with ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))
           ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))
        show ?thesis
          by (cases "netgmap sr s1", cases "netgmap sr s2", clarsimp)
             (metis (lifting, mono_tags) map_add_Some_iff)
    next
      assume "i  net_tree_ips n2"
      with ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))
        show ?thesis
          by simp (metis (lifting, mono_tags) fst_conv map_add_find_right)
    next
      assume "inet_tree_ips n1  net_tree_ips n2"
      with ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))
           ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))
        show ?thesis
          by simp (metis (lifting, mono_tags) fst_conv)
    qed
  qed

lemma netgmap_netmask_subnets' [elim]:
  assumes "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
      and "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
      and "s = SubnetS s1 s2"
    shows "netgmap sr s = netmask (net_tree_ips (n1  n2)) (σ, snd (netgmap sr s))"
  by (simp only: assms(3))
     (rule prod_eqI [OF netgmap_netmask_subnets [OF assms(1-2)]], simp)

lemma netgmap_subnet_split1:
  assumes "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
      and "net_tree_ips n1  net_tree_ips n2 = {}"
      and "net_ips s1 = net_tree_ips n1"
      and "net_ips s2 = net_tree_ips n2"
    shows "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
  proof (rule prod_eqI)
    show "fst (netgmap sr s1) = fst (netmask (net_tree_ips n1) (σ, snd (netgmap sr s1)))"
    proof (rule ext, simp, intro conjI impI)
      fix i
      assume "inet_tree_ips n1"
      with ‹net_tree_ips n1  net_tree_ips n2 = {} have "inet_tree_ips n2"
        by auto
      from assms(1) [simplified prod_eq_iff]
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i =
                 (if i  net_tree_ips n1  i  net_tree_ips n2 then Some (σ i) else None)"
          by simp
      also from inet_tree_ips n2 and ‹net_ips s2 = net_tree_ips n2
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s1) i"
          by (metis dom_fst_netgmap map_add_dom_app_simps(3))
      finally show "fst (netgmap sr s1) i = Some (σ i)"
        using inet_tree_ips n1 by simp
    next
      fix i
      assume "i  net_tree_ips n1"
      with ‹net_ips s1 = net_tree_ips n1 have "i  net_ips s1" by simp
      thus "fst (netgmap sr s1) i = None" by simp
    qed
  qed simp

lemma netgmap_subnet_split2:
  assumes "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
      and "net_ips s1 = net_tree_ips n1"
      and "net_ips s2 = net_tree_ips n2"
    shows "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
  proof (rule prod_eqI)
    show "fst (netgmap sr s2) = fst (netmask (net_tree_ips n2) (σ, snd (netgmap sr s2)))"
    proof (rule ext, simp, intro conjI impI)
      fix i
      assume "inet_tree_ips n2"
      from assms(1) [simplified prod_eq_iff]
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i =
                 (if i  net_tree_ips n1  i  net_tree_ips n2 then Some (σ i) else None)"
          by simp
      also from inet_tree_ips n2 and ‹net_ips s2 = net_tree_ips n2
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s2) i"
          by (metis dom_fst_netgmap map_add_dom_app_simps(1))
      finally show "fst (netgmap sr s2) i = Some (σ i)"
        using inet_tree_ips n2 by simp
    next
      fix i
      assume "i  net_tree_ips n2"
      with ‹net_ips s2 = net_tree_ips n2 have "i  net_ips s2" by simp
      thus "fst (netgmap sr s2) i = None" by simp
    qed
  qed simp

lemma netmap_fst_netgmap_rel:
  shows "(λi. map_option (fst o sr) (netmap s i)) = fst (netgmap sr s)"
  proof (induction s)
    fix ii s R
    show "(λi. map_option (fst  sr) (netmap (NodeS ii s R) i)) = fst (netgmap sr (NodeS ii s R))"
      by auto
  next
    fix s1 s2
    assume a1: "(λi. map_option (fst  sr) (netmap s1 i)) = fst (netgmap sr s1)"
       and a2: "(λi. map_option (fst  sr) (netmap s2 i)) = fst (netgmap sr s2)"
    show "(λi. map_option (fst  sr) (netmap (SubnetS s1 s2) i)) = fst (netgmap sr (SubnetS s1 s2))"
    proof (rule ext)
      fix i
      from a1 a2 have "map_option (fst  sr) ((netmap s1 ++ netmap s2) i)
                                    = (fst (netgmap sr s1) ++ fst (netgmap sr s2)) i"
        by (metis fst_conv map_add_dom_app_simps(1) map_add_dom_app_simps(3)
                  net_ips_is_dom_netmap netgmap_pair_dom)
      thus "map_option (fst  sr) (netmap (SubnetS s1 s2) i) = fst (netgmap sr (SubnetS s1 s2)) i"
        by simp
    qed
  qed

lemma netmap_is_fst_netgmap:
  assumes "netmap s' = netmap s"
    shows "fst (netgmap sr s') = fst (netgmap sr s)"
  using assms by (metis netmap_fst_netgmap_rel)

lemma netmap_is_fst_netgmap':
  assumes "netmap s' i = netmap s i"
    shows "fst (netgmap sr s') i = fst (netgmap sr s) i"
  using assms by (metis netmap_fst_netgmap_rel)

lemma fst_netgmap_pair_fst [simp]:
  "fst (netgmap (λ(p, q). (fst p, snd p, q)) s) = fst (netgmap fst s)"
  by (induction s) auto

text ‹Introduce streamlined alternatives to netgmap to simplify certain property
        statements and thus make them easier to understand and to present.›

fun netlift :: "('s  'g × 'l)  's net_state  (nat  'g option)"
  where
    "netlift sr (NodeS i s R) = [i  fst (sr s)]"
  | "netlift sr (SubnetS s t) = (netlift sr s) ++ (netlift sr t)"

lemma fst_netgmap_netlift:
  "fst (netgmap sr s) = netlift sr s"
  by (induction s) simp_all

fun netliftl :: "('s  'g × 'l)  's net_state  'l net_state"
  where
    "netliftl sr (NodeS i s R) = NodeS i (snd (sr s)) R"
  | "netliftl sr (SubnetS s t) = SubnetS (netliftl sr s) (netliftl sr t)"

lemma snd_netgmap_netliftl:
  "snd (netgmap sr s) = netliftl sr s"
  by (induction s) simp_all
 
lemma netgmap_netlift_netliftl: "netgmap sr s = (netlift sr s, netliftl sr s)"
  by rule (simp_all add: fst_netgmap_netlift snd_netgmap_netliftl)

end

Theory AWN_SOS

(*  Title:       AWN_SOS.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Semantics of the Algebra of Wireless Networks"

theory AWN_SOS
imports TransitionSystems AWN
begin

subsection "Table 1: Structural operational semantics for sequential process expressions "

inductive_set
  seqp_sos
  :: "('s, 'm, 'p, 'l) seqp_env  ('s × ('s, 'm, 'p, 'l) seqp, 'm seq_action) transition set"
  for Γ :: "('s, 'm, 'p, 'l) seqp_env"
where
    broadcastT: "((ξ, {l}broadcast(smsg).p),          broadcast (smsg ξ),         (ξ, p))  seqp_sos Γ"
  | groupcastT: "((ξ, {l}groupcast(sips, smsg).p),    groupcast (sips ξ) (smsg ξ), (ξ, p))  seqp_sos Γ"
  | unicastT:   "((ξ, {l}unicast(sip, smsg).p  q),   unicast (sip ξ) (smsg ξ),    (ξ, p))  seqp_sos Γ"
  | notunicastT:"((ξ, {l}unicast(sip, smsg).p  q),    ¬unicast (sip ξ),          (ξ, q))  seqp_sos Γ"
  | sendT:      "((ξ, {l}send(smsg).p),               send (smsg ξ),              (ξ, p))  seqp_sos Γ"
  | deliverT:   "((ξ, {l}deliver(sdata).p),           deliver (sdata ξ),          (ξ, p))  seqp_sos Γ"
  | receiveT:   "((ξ, {l}receive(umsg).p),            receive msg,       (umsg msg ξ, p))  seqp_sos Γ"
  | assignT:    "((ξ, {l}u p),                      τ,                        (u ξ, p))  seqp_sos Γ"

  | callT:      " ((ξ, Γ pn), a, (ξ', p'))  seqp_sos Γ  
                 ((ξ, call(pn)), a, (ξ', p'))  seqp_sos Γ" (* TPB: quite different to Table 1 *)

  | choiceT1:   "((ξ, p), a, (ξ', p'))  seqp_sos Γ   ((ξ, p  q), a, (ξ', p'))  seqp_sos Γ"
  | choiceT2:   "((ξ, q), a, (ξ', q'))  seqp_sos Γ   ((ξ, p  q), a, (ξ', q'))  seqp_sos Γ"

  | guardT:     "ξ'  g ξ  ((ξ, {l}g p), τ, (ξ', p))  seqp_sos Γ"

inductive_cases
      seqp_callTE [elim]:      "((ξ, call(pn)), a, (ξ', q))  seqp_sos Γ"
  and seqp_choiceTE [elim]:    "((ξ, p1  p2), a, (ξ', q))  seqp_sos Γ"

lemma seqp_broadcastTE [elim]:
  "((ξ, {l}broadcast(smsg). p), a, (ξ', q))  seqp_sos Γ;
    a = broadcast (smsg ξ); ξ' = ξ; q = p  P  P"
  by (ind_cases "((ξ, {l}broadcast(smsg). p), a, (ξ', q))  seqp_sos Γ") simp

lemma seqp_groupcastTE [elim]:
  "((ξ, {l}groupcast(sips, smsg). p), a, (ξ', q))  seqp_sos Γ;
    a = groupcast (sips ξ) (smsg ξ); ξ' = ξ; q = p  P  P"
  by (ind_cases "((ξ, {l}groupcast(sips, smsg). p), a, (ξ', q))  seqp_sos Γ") simp

lemma seqp_unicastTE [elim]:
  "((ξ, {l}unicast(sip, smsg). p  q), a, (ξ', r))  seqp_sos Γ;
    a = unicast (sip ξ) (smsg ξ); ξ' = ξ; r = p  P;
    a = ¬unicast (sip ξ); ξ' = ξ; r = q  P  P"
  by (ind_cases "((ξ, {l}unicast(sip, smsg). p  q), a, (ξ', r))  seqp_sos Γ") simp_all

lemma seqp_sendTE [elim]:
  "((ξ, {l}send(smsg). p), a, (ξ', q))  seqp_sos Γ;
    a = send (smsg ξ); ξ' = ξ; q = p  P  P"
  by (ind_cases "((ξ, {l}send(smsg). p), a, (ξ', q))  seqp_sos Γ") simp

lemma seqp_deliverTE [elim]:
  "((ξ, {l}deliver(sdata). p), a, (ξ', q))  seqp_sos Γ;
    a = deliver (sdata ξ); ξ' = ξ; q = p  P  P"
  by (ind_cases "((ξ, {l}deliver(sdata). p), a, (ξ', q))  seqp_sos Γ") simp

lemma seqp_receiveTE [elim]:
  "((ξ, {l}receive(umsg). p), a, (ξ', q))  seqp_sos Γ;
    msg. a = receive msg; ξ' = umsg msg ξ; q = p  P  P"
  by (ind_cases "((ξ, {l}receive(umsg). p), a, (ξ', q))  seqp_sos Γ") simp

lemma seqp_assignTE [elim]:
  "((ξ, {l}u p), a, (ξ', q))  seqp_sos Γ; a = τ; ξ' = u ξ; q = p  P  P"
  by (ind_cases "((ξ, {l}u p), a, (ξ', q))  seqp_sos Γ") simp

lemma seqp_guardTE [elim]:
  "((ξ, {l}g p), a, (ξ', q))  seqp_sos Γ; a = τ; ξ'  g ξ; q = p  P  P"
  by (ind_cases "((ξ, {l}g p), a, (ξ', q))  seqp_sos Γ") simp

lemmas seqpTEs =
  seqp_broadcastTE
  seqp_groupcastTE
  seqp_unicastTE
  seqp_sendTE
  seqp_deliverTE
  seqp_receiveTE
  seqp_assignTE
  seqp_callTE
  seqp_choiceTE
  seqp_guardTE

declare seqp_sos.intros [intro]

subsection "Table 2: Structural operational semantics for parallel process expressions "

inductive_set
  parp_sos :: "('s1, 'm seq_action) transition set
                     ('s2, 'm seq_action) transition set
                     ('s1 × 's2, 'm seq_action) transition set"
  for S :: "('s1, 'm seq_action) transition set"
  and T :: "('s2, 'm seq_action) transition set"
where
    parleft:  " (s, a, s')  S; m. a  receive m   ((s, t), a, (s', t))  parp_sos S T"
  | parright: " (t, a, t')  T; m. a  send m   ((s, t), a, (s, t'))  parp_sos S T"
  | parboth:  " (s, receive m, s')  S; (t, send m, t')  T 
               ((s, t), τ, (s', t'))  parp_sos S T"

lemma par_broadcastTE [elim]:
  "((s, t), broadcast m, (s', t'))  parp_sos S T;
    (s, broadcast m, s')  S; t' = t  P;
    (t, broadcast m, t')  T; s' = s  P  P"
  by (ind_cases "((s, t), broadcast m, (s', t'))  parp_sos S T") simp_all

lemma par_groupcastTE [elim]:
  "((s, t), groupcast ips m, (s', t'))  parp_sos S T;
    (s, groupcast ips m, s')  S; t' = t  P;
    (t, groupcast ips m, t')  T; s' = s  P  P"
  by (ind_cases "((s, t), groupcast ips m, (s', t'))  parp_sos S T") simp_all

lemma par_unicastTE [elim]:
  "((s, t), unicast i m, (s', t'))  parp_sos S T;
    (s, unicast i m, s')  S; t' = t  P;
    (t, unicast i m, t')  T; s' = s  P  P"
  by (ind_cases "((s, t), unicast i m, (s', t'))  parp_sos S T") simp_all

lemma par_notunicastTE [elim]:
  "((s, t), notunicast i, (s', t'))  parp_sos S T;
    (s, notunicast i, s')  S; t' = t  P;
    (t, notunicast i, t')  T; s' = s  P  P"
  by (ind_cases "((s, t), notunicast i, (s', t'))  parp_sos S T") simp_all

lemma par_sendTE [elim]:
  "((s, t), send m, (s', t'))  parp_sos S T;
    (s, send m, s')  S; t' = t  P  P"
  by (ind_cases "((s, t), send m, (s', t'))  parp_sos S T") auto

lemma par_deliverTE [elim]:
  "((s, t), deliver d, (s', t'))  parp_sos S T;
    (s, deliver d, s')  S; t' = t  P;
    (t, deliver d, t')  T; s' = s  P  P"
  by (ind_cases "((s, t), deliver d, (s', t'))  parp_sos S T") simp_all

lemma par_receiveTE [elim]:
  "((s, t), receive m, (s', t'))  parp_sos S T;
    (t, receive m, t')  T; s' = s  P  P"
  by (ind_cases "((s, t), receive m, (s', t'))  parp_sos S T") auto

inductive_cases par_tauTE: "((s, t), τ, (s', t'))  parp_sos S T"

lemmas parpTEs =
  par_broadcastTE
  par_groupcastTE
  par_unicastTE
  par_notunicastTE
  par_sendTE
  par_deliverTE
  par_receiveTE

lemma parp_sos_cases [elim]:
  assumes "((s, t), a, (s', t'))  parp_sos S T"
      and " (s, a, s')  S; m. a  receive m; t' = t   P"
      and " (t, a, t')  T; m. a  send m; s' = s   P"
      and "m.  (s, receive m, s')  S; (t, send m, t')  T   P"
    shows "P"
  using assms by cases auto

definition
  par_comp :: "('s1, 'm seq_action) automaton
               ('s2, 'm seq_action) automaton
               ('s1 × 's2, 'm seq_action) automaton"
  ("(_ ⟨⟨ _)" [102, 103] 102)
where
  "s ⟨⟨ t   init = init s × init t, trans = parp_sos (trans s) (trans t) "

lemma trans_par_comp [simp]:
  "trans (s ⟨⟨ t) = parp_sos (trans s) (trans t)"
  unfolding par_comp_def by simp

lemma init_par_comp [simp]:
  "init (s ⟨⟨ t) = init s × init t"
  unfolding par_comp_def by simp

subsection "Table 3: Structural operational semantics for node expressions "

inductive_set
  node_sos :: "('s, 'm seq_action) transition set  ('s net_state, 'm node_action) transition set"
  for S :: "('s, 'm seq_action) transition set"
where
    node_bcast:
    "(s, broadcast m, s')  S  (NodeS i s R, R:*cast(m), NodeS i s' R)  node_sos S"
  | node_gcast:
    "(s, groupcast D m, s')  S  (NodeS i s R, (RD):*cast(m), NodeS i s' R)  node_sos S"
  | node_ucast:
    " (s, unicast d m, s')  S; dR   (NodeS i s R, {d}:*cast(m), NodeS i s' R)  node_sos S"
  | node_notucast:
    " (s, ¬unicast d, s')  S; dR   (NodeS i s R, τ, NodeS i s' R)  node_sos S"
  | node_deliver:
    "(s, deliver d, s')  S  (NodeS i s R, i:deliver(d), NodeS i s' R)  node_sos S"
  | node_receive:
    "(s, receive m, s')  S  (NodeS i s R, {i}¬{}:arrive(m), NodeS i s' R)  node_sos S"
  | node_tau:
    "(s, τ, s')  S          (NodeS i s R, τ, NodeS i s' R)  node_sos S"
  | node_arrive:
    "(NodeS i s R, {}¬{i}:arrive(m),  NodeS i s R)  node_sos S"
  | node_connect1:
    "(NodeS i s R, connect(i, i'),    NodeS i s (R  {i'}))  node_sos S"
  | node_connect2:
    "(NodeS i s R, connect(i', i),    NodeS i s (R  {i'}))  node_sos S"
  | node_disconnect1:
    "(NodeS i s R, disconnect(i, i'), NodeS i s (R - {i'}))  node_sos S"
  | node_disconnect2:
    "(NodeS i s R, disconnect(i', i), NodeS i s (R - {i'}))  node_sos S"
  | node_connect_other:
    " i  i'; i  i''   (NodeS i s R, connect(i', i''), NodeS i s R)  node_sos S"
  | node_disconnect_other:
    " i  i'; i  i''   (NodeS i s R, disconnect(i', i''), NodeS i s R)  node_sos S"

inductive_cases node_arriveTE:  "(NodeS i s R, ii¬ni:arrive(m), NodeS i s' R)  node_sos S"
            and node_arriveTE': "(NodeS i s R, H¬K:arrive(m), s')  node_sos S"
            and node_castTE:    "(NodeS i s R, RM:*cast(m), NodeS i s' R')  node_sos S"
            and node_castTE':   "(NodeS i s R, RM:*cast(m), s')  node_sos S"
            and node_deliverTE: "(NodeS i s R, i:deliver(d), NodeS i s' R)  node_sos S"
            and node_deliverTE': "(s, i:deliver(d), s')  node_sos S"
            and node_deliverTE'': "(NodeS ii s R, i:deliver(d), s')  node_sos S"
            and node_tauTE:     "(NodeS i s R, τ, NodeS i s' R)  node_sos S"
            and node_tauTE':    "(NodeS i s R, τ, s')  node_sos S"
            and node_connectTE: "(NodeS ii s R, connect(i, i'), NodeS ii s' R')  node_sos S"
            and node_connectTE': "(NodeS ii s R, connect(i, i'), s')  node_sos S"
            and node_disconnectTE: "(NodeS ii s R, disconnect(i, i'), NodeS ii s' R')  node_sos S"
            and node_disconnectTE': "(NodeS ii s R, disconnect(i, i'), s')  node_sos S"

lemma node_sos_never_newpkt [simp]:
  assumes "(s, a, s')  node_sos S"
    shows "a  i:newpkt(d, di)"
  using assms by cases auto

lemma arrives_or_not:
  assumes "(NodeS i s R, ii¬ni:arrive(m), NodeS i' s' R')  node_sos S"
    shows "(ii = {i}  ni = {})  (ii = {}  ni = {i})"
  using assms by rule simp_all

definition
  node_comp :: "ip  ('s, 'm seq_action) automaton  ip set
                    ('s net_state, 'm node_action) automaton"
    ("(_ : (_) : _)" [0, 0, 0] 104)
where
  "i : np : Ri   init = {NodeS i s Ri|s. s  init np}, trans = node_sos (trans np) "

lemma trans_node_comp:
  "trans (i : np : Ri) = node_sos (trans np)"
  unfolding node_comp_def by simp

lemma init_node_comp:
  "init (i : np : Ri) = {NodeS i s Ri|s. s  init np}"
  unfolding node_comp_def by simp

lemmas node_comps = trans_node_comp init_node_comp

lemma trans_par_node_comp [simp]:
  "trans (i : s ⟨⟨ t : R) = node_sos (parp_sos (trans s) (trans t))"
  unfolding node_comp_def by simp

lemma snd_par_node_comp [simp]:
  "init (i : s ⟨⟨ t : R) = {NodeS i st R|st. st  init s × init t}"
  unfolding node_comp_def by simp

lemma node_sos_dest_is_net_state:
  assumes "(s, a, s')  node_sos S"
    shows "i' P' R'. s' = NodeS i' P' R'"
  using assms by induct auto

lemma node_sos_dest:
  assumes "(NodeS i p R, a, s')  node_sos S"
    shows "P' R'. s' = NodeS i P' R'"
  using assms assms [THEN node_sos_dest_is_net_state]
  by - (erule node_sos.cases, auto)

lemma node_sos_states [elim]:
  assumes "(ns, a, ns')  node_sos S"
  obtains i s R s' R' where "ns  = NodeS i s  R"
                        and "ns' = NodeS i s' R'"
  proof -
    assume [intro!]: "i s R s' R'. ns = NodeS i s R  ns' = NodeS i s' R'  thesis"
    from assms(1) obtain i s R where "ns = NodeS i s R"
      by (cases ns) auto
    moreover with assms(1) obtain s' R' where "ns' = NodeS i s' R'"
      by (metis node_sos_dest)
    ultimately show thesis ..
  qed

lemma node_sos_cases [elim]:
  "(NodeS i p R, a, NodeS i p' R')  node_sos S 
  (m .        a = R:*cast(m);          R' = R; (p, broadcast m, p')  S   P) 
  (m D.       a = (R  D):*cast(m);    R' = R; (p, groupcast D m, p')  S   P) 
  (d m.       a = {d}:*cast(m);        R' = R; (p, unicast d m, p')  S; d  R   P) 
  (d.         a = τ;                   R' = R; (p, ¬unicast d, p')  S; d  R   P) 
  (d.         a = i:deliver(d);        R' = R; (p, deliver d, p')  S   P) 
  (m.         a = {i}¬{}:arrive(m);    R' = R; (p, receive m, p')  S   P) 
  (             a = τ;                   R' = R; (p, τ, p')  S   P) 
  (m.         a = {}¬{i}:arrive(m);    R' = R; p = p'   P) 
  (i i'.      a = connect(i, i');      R' = R  {i'}; p = p'   P) 
  (i i'.      a = connect(i', i);      R' = R  {i'}; p = p'   P) 
  (i i'.      a = disconnect(i, i');   R' = R - {i'}; p = p'   P) 
  (i i'.      a = disconnect(i', i);   R' = R - {i'}; p = p'   P) 
  (i i' i''.  a = connect(i', i'');    R' = R; p = p'; i  i'; i  i''   P) 
  (i i' i''.  a = disconnect(i', i''); R' = R; p = p'; i  i'; i  i''   P) 
  P"
  by (erule node_sos.cases) simp_all

subsection "Table 4: Structural operational semantics for partial network expressions "

inductive_set
  pnet_sos :: "('s net_state, 'm node_action) transition set
                     ('s net_state, 'm node_action) transition set
                     ('s net_state, 'm node_action) transition set"
  for S :: "('s net_state, 'm node_action) transition set"
  and T :: "('s net_state, 'm node_action) transition set"
where
    pnet_cast1: " (s, R:*cast(m), s')  S; (t, H¬K:arrive(m), t')  T; H  R; K  R = {} 
       (SubnetS s t, R:*cast(m), SubnetS s' t')  pnet_sos S T"

  | pnet_cast2: " (s, H¬K:arrive(m), s')  S; (t, R:*cast(m), t')  T;  H  R; K  R = {} 
       (SubnetS s t, R:*cast(m), SubnetS s' t')  pnet_sos S T"

  | pnet_arrive: " (s, H¬K:arrive(m), s')  S; (t, H'¬K':arrive(m), t')  T 
       (SubnetS s t,  (H  H')¬(K  K'):arrive(m), SubnetS s' t')  pnet_sos S T"

  | pnet_deliver1: "(s, i:deliver(d), s')  S
       (SubnetS s t, i:deliver(d), SubnetS s' t)  pnet_sos S T"
  | pnet_deliver2: " (t, i:deliver(d), t')  T 
       (SubnetS s t, i:deliver(d), SubnetS s t')  pnet_sos S T"

  | pnet_tau1: "(s, τ, s')  S  (SubnetS s t, τ, SubnetS s' t)  pnet_sos S T"
  | pnet_tau2: "(t, τ, t')  T  (SubnetS s t, τ, SubnetS s t')  pnet_sos S T"

  | pnet_connect: " (s, connect(i, i'), s')  S; (t, connect(i, i'), t')  T 
       (SubnetS s t, connect(i, i'), SubnetS s' t')  pnet_sos S T"

  | pnet_disconnect: " (s, disconnect(i, i'), s')  S; (t, disconnect(i, i'), t')  T 
       (SubnetS s t, disconnect(i, i'), SubnetS s' t')  pnet_sos S T"

inductive_cases partial_castTE [elim]:       "(s, R:*cast(m), s')  pnet_sos S T"
            and partial_arriveTE [elim]:     "(s, H¬K:arrive(m), s')  pnet_sos S T"
            and partial_deliverTE [elim]:    "(s, i:deliver(d), s')  pnet_sos S T"
            and partial_tauTE [elim]:        "(s, τ, s')  pnet_sos S T"
            and partial_connectTE [elim]:    "(s, connect(i, i'), s')  pnet_sos S T"
            and partial_disconnectTE [elim]: "(s, disconnect(i, i'), s')  pnet_sos S T"

lemma pnet_sos_never_newpkt:
  assumes "(st, a, st')  pnet_sos S T"
      and "i d di a s s'. (s, a, s')  S  a  i:newpkt(d, di)"
      and "i d di a t t'. (t, a, t')  T  a  i:newpkt(d, di)"
    shows "a  i:newpkt(d, di)"
  using assms(1) by cases (auto dest!: assms(2-3))

fun pnet :: "(ip  ('s, 'm seq_action) automaton)
               net_tree  ('s net_state, 'm node_action) automaton"
where
    "pnet np (i; Ri)  =  i : np i : Ri"
  | "pnet np (p1  p2) =  init = {SubnetS s1 s2 |s1 s2. s1  init (pnet np p1)
                                                       s2  init (pnet np p2)},
                           trans = pnet_sos (trans (pnet np p1)) (trans (pnet np p2)) "

lemma pnet_node_init [elim, simp]:
  assumes "s  init (pnet np i; R)"
    shows "s  { NodeS i s R |s. s  init (np i)}"
  using assms by (simp add: node_comp_def)

lemma pnet_node_init' [elim]:
 assumes "s  init (pnet np i; R)"
 obtains ns where "s = NodeS i ns R"
             and "ns  init (np i)"
   using assms by (auto simp add: node_comp_def)

lemma pnet_node_trans [elim, simp]:
  assumes "(s, a, s')  trans (pnet np i; R)"
    shows "(s, a, s')  node_sos (trans (np i))"
  using assms by (simp add: trans_node_comp)

lemma pnet_never_newpkt':
  assumes "(s, a, s')  trans (pnet np n)"
    shows "i d di. a  i:newpkt(d, di)"
  using assms proof (induction n arbitrary: s a s')
    fix n1 n2 s a s'
    assume IH1: "s a s'. (s, a, s')  trans (pnet np n1)  i d di. a  i:newpkt(d, di)"
       and IH2: "s a s'. (s, a, s')  trans (pnet np n2)  i d di. a  i:newpkt(d, di)"
       and "(s, a, s')  trans (pnet np (n1  n2))"
    show "i d di. a  i:newpkt(d, di)"
    proof (intro allI)
      fix i d di
      from (s, a, s')  trans (pnet np (n1  n2))
        have "(s, a, s')  pnet_sos (trans (pnet np n1)) (trans (pnet np n2))"
          by simp
      thus "a  i:newpkt(d, di)"
        by (rule pnet_sos_never_newpkt) (auto dest!: IH1 IH2)
    qed
  qed (simp add: node_comps)

lemma pnet_never_newpkt:
  assumes "(s, a, s')  trans (pnet np n)"
    shows "a  i:newpkt(d, di)"
  proof -
    from assms have "i d di. a  i:newpkt(d, di)"
      by (rule pnet_never_newpkt')
    thus ?thesis by clarsimp
  qed

subsection "Table 5: Structural operational semantics for complete network expressions "

inductive_set
  cnet_sos :: "('s, ('m::msg) node_action) transition set
                     ('s, 'm node_action) transition set"
  for S :: "('s, 'm node_action) transition set"
where
    cnet_connect: "(s, connect(i, i'), s')  S   (s, connect(i, i'), s')  cnet_sos S"
  | cnet_disconnect: "(s, disconnect(i, i'), s')  S   (s, disconnect(i, i'), s')  cnet_sos S"
  | cnet_cast: "(s, R:*cast(m), s')  S   (s, τ, s')  cnet_sos S"
  | cnet_tau: "(s, τ, s')  S   (s, τ, s')  cnet_sos S"
  | cnet_deliver: "(s, i:deliver(d), s')  S   (s, i:deliver(d), s')  cnet_sos S"
  | cnet_newpkt: "(s, {i}¬K:arrive(newpkt(d, di)), s')  S   (s, i:newpkt(d, di), s')  cnet_sos S"

inductive_cases connect_completeTE: "(s, connect(i, i'), s')  cnet_sos S"
            and disconnect_completeTE: "(s, disconnect(i, i'), s')  cnet_sos S"
            and tau_completeTE: "(s, τ, s')  cnet_sos S"
            and deliver_completeTE: "(s, i:deliver(d), s')  cnet_sos S"
            and newpkt_completeTE: "(s, i:newpkt(d, di), s')  cnet_sos S"

lemmas completeTEs = connect_completeTE
                     disconnect_completeTE
                     tau_completeTE
                     deliver_completeTE
                     newpkt_completeTE

lemma complete_no_cast [simp]:
  "(s, R:*cast(m), s')  cnet_sos T"
  proof
    assume "(s, R:*cast(m), s')  cnet_sos T"
    hence "R:*cast(m)  R:*cast(m)"
     by (rule cnet_sos.cases) auto
    thus False by simp
  qed

lemma complete_no_arrive [simp]:
  "(s, ii¬ni:arrive(m), s')  cnet_sos T"
  proof
    assume "(s, ii¬ni:arrive(m), s')  cnet_sos T"
    hence "ii¬ni:arrive(m)  ii¬ni:arrive(m)"
     by (rule cnet_sos.cases) auto
    thus False by simp
  qed

abbreviation
  closed :: "('s net_state, ('m::msg) node_action) automaton  ('s net_state, 'm node_action) automaton"
where
  "closed  (λA. A  trans := cnet_sos (trans A) )"

end

Theory AWN_Cterms

(*  Title:       AWN_Cterms.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Control terms and well-definedness of sequential processes"

theory AWN_Cterms
imports AWN
begin

subsection "Microsteps "

text ‹
  We distinguish microsteps from `external' transitions (observable or not). Here, they are
  a kind of `hypothetical computation', since, unlike τ›-transitions, they do not make
  choices but rather `compute' which choices are possible.
›

inductive
  microstep :: "('s, 'm, 'p, 'l) seqp_env
                 ('s, 'm, 'p, 'l) seqp
                 ('s, 'm, 'p, 'l) seqp
                 bool"
for Γ :: "('s, 'm, 'p, 'l) seqp_env"
where
    microstep_choiceI1 [intro, simp]: "microstep Γ (p1  p2) p1"
  | microstep_choiceI2 [intro, simp]: "microstep Γ (p1  p2) p2"
  | microstep_callI [intro, simp]: "microstep Γ (call(pn)) (Γ pn)"

abbreviation microstep_rtcl
where "microstep_rtcl Γ p q  (microstep Γ)** p q"

abbreviation microstep_tcl
where "microstep_tcl Γ p q  (microstep Γ)++ p q"

syntax
  "_microstep"
     :: "[('s, 'm, 'p, 'l) seqp, ('s, 'm, 'p, 'l) seqp_env, ('s, 'm, 'p, 'l) seqp]  bool"
     ("(_) ↝⇘_ (_)" [61, 0, 61] 50)
  "_microstep_rtcl"
     :: "[('s, 'm, 'p, 'l) seqp, ('s, 'm, 'p, 'l) seqp_env, ('s, 'm, 'p, 'l) seqp]  bool"
     ("(_) ↝⇘_* (_)" [61, 0, 61] 50)
  "_microstep_tcl"
     :: "[('s, 'm, 'p, 'l) seqp, ('s, 'm, 'p, 'l) seqp_env, ('s, 'm, 'p, 'l) seqp]  bool"
     ("(_) ↝⇘_+ (_)" [61, 0, 61] 50)

translations
  "p1Γ p2"   "CONST microstep Γ p1 p2"
  "p1Γ* p2"  "CONST microstep_rtcl Γ p1 p2"
  "p1Γ+ p2"  "CONST microstep_tcl Γ p1 p2"

lemma microstep_choiceD [dest]:
  "(p1  p2)Γ p  p = p1  p = p2"
  by (ind_cases "(p1  p2)Γ p") auto

lemma microstep_choiceE [elim]:
  " (p1  p2)Γ p;
     (p1  p2)Γ p1  P;
     (p1  p2)Γ p2  P   P"
  by (blast)

lemma microstep_callD [dest]:
  "(call(pn))Γ p  p = Γ pn"
  by (ind_cases "(call(pn))Γ p")

lemma microstep_callE [elim]:
  " (call(pn))Γ p;  p = Γ(pn)  P   P"
  by auto

lemma no_microstep_guard: "¬ (({l}g p)Γ q)"
  by (rule notI) (ind_cases "({l}g p)Γ q")

lemma no_microstep_assign: "¬ ({l}f p)Γ q"
  by (rule notI) (ind_cases "({l}f p)Γ q")

lemma no_microstep_unicast: "¬ (({l}unicast(sip, smsg).p  q)Γ r)"
  by (rule notI) (ind_cases "({l}unicast(sip, smsg).p  q)Γ r")

lemma no_microstep_broadcast: "¬ (({l}broadcast(smsg).p)Γ q)"
  by (rule notI) (ind_cases "({l}broadcast(smsg).p)Γ q")

lemma no_microstep_groupcast: "¬ (({l}groupcast(sips, smsg).p)Γ q)"
  by (rule notI) (ind_cases "({l}groupcast(sips, smsg).p)Γ q")

lemma no_microstep_send: "¬ (({l}send(smsg).p)Γ q)"
  by (rule notI) (ind_cases "({l}send(smsg).p)Γ q")

lemma no_microstep_deliver: "¬ (({l}deliver(sdata).p)Γ q)"
  by (rule notI) (ind_cases "({l}deliver(sdata).p)Γ q")

lemma no_microstep_receive: "¬ (({l}receive(umsg).p)Γ q)"
  by (rule notI) (ind_cases "({l}receive(umsg).p)Γ q")

lemma microstep_call_or_choice [dest]:
  assumes "pΓ q"
    shows "(pn. p = call(pn))  (p1 p2. p = p1  p2)"
  using assms by clarsimp (metis microstep.simps)

lemmas no_microstep [intro,simp] =
  no_microstep_guard
  no_microstep_assign
  no_microstep_unicast
  no_microstep_broadcast
  no_microstep_groupcast
  no_microstep_send
  no_microstep_deliver
  no_microstep_receive

subsection "Wellformed process specifications "

text ‹
  A process specification Γ› is wellformed if its @{term "microstep Γ"} relation is
  free of loops and infinite chains.

  For example, these specifications are not wellformed:
    @{term "Γ1(p1) = call(p1)"}

    @{term "Γ2(p1) = send(msg).call(p1)  call(p1)"}

    @{term "Γ3(p1) = send(msg).call(p2)"}
    @{term "Γ3(p2) = call(p3)"}
    @{term "Γ3(p3) = call(p4)"}
    @{term "Γ3(p4) = call(p5)"}
    \ldots
›

definition
  wellformed :: "('s, 'm, 'p, 'l) seqp_env  bool"
where
  "wellformed Γ = wf {(q, p). pΓ q}"

lemma wellformed_defP: "wellformed Γ = wfP (λq p. pΓ q)"
  unfolding wellformed_def wfP_def by simp

text ‹
  The induction rule for @{term "wellformed Γ"} is stronger than @{thm seqp.induct} because
  the case for @{term "call(pn)"} can be shown with the assumption on @{term "Γ pn"}.
›

lemma wellformed_induct
  [consumes 1, case_names ASSIGN CHOICE CALL GUARD UCAST BCAST GCAST SEND DELIVER RECEIVE,
   induct set: wellformed]:
  assumes "wellformed Γ"
      and ASSIGN:  "l f p.          wellformed Γ  P ({l}f p)"
      and GUARD:   "l f p.          wellformed Γ  P ({l}f p)"
      and UCAST:   "l fip fmsg p q. wellformed Γ  P ({l}unicast(fip, fmsg). p  q)"
      and BCAST:   "l fmsg p.       wellformed Γ  P ({l}broadcast(fmsg). p)"
      and GCAST:   "l fips fmsg p.  wellformed Γ  P ({l}groupcast(fips, fmsg). p)"
      and SEND:    "l fmsg p.       wellformed Γ  P ({l}send(fmsg). p)"
      and DELIVER: "l fdata p.      wellformed Γ  P ({l}deliver(fdata). p)"
      and RECEIVE: "l fmsg p.       wellformed Γ  P ({l}receive(fmsg). p)"
      and CHOICE:  "p1 p2.         wellformed Γ; P p1; P p2   P (p1  p2)"
      and CALL:    "pn.            wellformed Γ; P (Γ pn)   P (call(pn))"
    shows "P a"
  using assms(1) unfolding wellformed_defP
  proof (rule wfP_induct_rule, case_tac x, simp_all)
    fix p1 p2
    assume "q. (p1  p2)Γ q  P q"
    then obtain "P p1" and "P p2" by (auto intro!: microstep.intros)
    thus "P (p1  p2)" by (rule CHOICE [OF ‹wellformed Γ])
  next
    fix pn
    assume "q. (call(pn))Γ q  P q"
    hence "P (Γ pn)" by (auto intro!: microstep.intros)
    thus "P (call(pn))" by (rule CALL [OF ‹wellformed Γ])
  qed (auto intro: assms)

subsection "Start terms (sterms) "

text ‹
  Formulate sets of local subterms from which an action is directly possible. Since the
  process specification @{term "Γ"} is not considered, only choice terms @{term "p1  p2"}
  are traversed, and not @{term "call(p)"} terms.
›

fun stermsl :: "('s, 'm, 'p, 'l) seqp  ('s, 'm, 'p , 'l) seqp set"
where
    "stermsl (p1  p2) = stermsl p1  stermsl p2"
  | "stermsl p          = {p}"

lemma stermsl_nobigger: "q  stermsl p  size q  size p"
  by (induct p) auto

lemma stermsl_no_choice[simp]: "p1  p2  stermsl p"
  by (induct p) simp_all

lemma stermsl_choice_disj[simp]:
  "p  stermsl (p1  p2) = (p  stermsl p1  p  stermsl p2)"
  by simp

lemma stermsl_in_branch[elim]:
  "p  stermsl (p1  p2); p  stermsl p1  P; p  stermsl p2  P  P"
  by auto

lemma stermsl_commute:
  "stermsl (p1  p2) = stermsl (p2  p1)"
  by simp (rule Un_commute)

lemma stermsl_not_empty:
  "stermsl p  {}"
  by (induct p) auto

lemma stermsl_idem [simp]:
  "(qstermsl p. stermsl q) = stermsl p"
  by (induct p) simp_all

lemma stermsl_in_wfpf:
  assumes AA: "A  {(q, p). pΓ q} `` A"
      and *: "p  A"
    shows "rstermsl p. r  A"
  using *
  proof (induction p)
    fix p1 p2
    assume IH1: "p1  A  rstermsl p1. r  A"
       and IH2: "p2  A  rstermsl p2. r  A"
       and *: "p1  p2  A"
    from * and AA have "p1  p2  {(q, p). pΓ q} `` A" by auto
    hence "p1  A  p2  A" by auto
    hence "(rstermsl p1. r  A)  (rstermsl p2. r  A)"
      proof
        assume "p1  A" hence "rstermsl p1. r  A" by (rule IH1) thus ?thesis ..
      next
        assume "p2  A" hence "rstermsl p2. r  A" by (rule IH2) thus ?thesis ..
      qed
      hence "rstermsl p1  stermsl p2. r  A" by blast
      thus "rstermsl (p1  p2). r  A" by simp
    next case UCAST from UCAST.prems show ?case by auto
  qed auto

lemma nocall_stermsl_max:
  assumes "r  stermsl p"
      and "not_call r"
    shows "¬ (rΓ q)"
  using assms
  by (induction p) auto

theorem wf_no_direct_calls[intro]:
    fixes Γ :: "('s, 'm, 'p, 'l) seqp_env"
  assumes no_calls: "pn. pn'. call(pn')  stermsl(Γ(pn))"
    shows "wellformed Γ"
  unfolding wellformed_def wfP_def
  proof (rule wfI_pf)
    fix A
    assume ARA: "A  {(q, p). pΓ q} `` A"
    hence hasnext: "p. p  A  q. pΓ q  q  A" by auto
    show "A = {}"
    proof (rule Set.equals0I)
      fix p assume "p  A" thus "False"
      proof (induction p)
        fix l f p'
        assume *: "{l}f p'  A"
        from hasnext [OF *] have "q. ({l}f p')Γ q" by simp
        thus "False" by simp
      next
        fix p1 p2
        assume *: "p1  p2  A"
         and IH1: "p1  A  False"
         and IH2: "p2  A  False"
        have "q. (p1  p2)Γ q  q  A" by (rule hasnext [OF *])
        hence "p1  A  p2  A" by auto
        thus "False" by (auto dest: IH1 IH2)
      next
        fix pn
        assume "call(pn)  A"
        hence "q. (call(pn))Γ q  q  A" by (rule hasnext)
        hence "Γ(pn)  A" by auto

        with ARA [THEN stermsl_in_wfpf] obtain q where "qstermsl (Γ pn)" and "q  A" by metis
        hence "not_call q" using no_calls [of pn]
          unfolding not_call_def by auto

        from hasnext [OF q  A] obtain q' where "qΓ q'" by auto
        moreover from  q  stermsl (Γ pn) ‹not_call q have "¬ (qΓ q')"
          by (rule nocall_stermsl_max)
        ultimately show "False" by simp
      qed (auto dest: hasnext)
    qed
  qed

subsection "Start terms"

text ‹
  The start terms are those terms, relative to a wellformed process specification Γ›,
  from which transitions can occur directly.
›

function (domintros, sequential) sterms
  :: "('s, 'm, 'p, 'l) seqp_env  ('s, 'm, 'p, 'l) seqp  ('s, 'm, 'p, 'l) seqp set"
  where
    sterms_choice: "sterms Γ (p1  p2)  = sterms Γ p1  sterms Γ p2"
  | sterms_call:   "sterms Γ (call(pn))  = sterms Γ (Γ pn)"
  | sterms_other:  "sterms Γ p           = {p}"
  by pat_completeness auto

lemma sterms_dom_basic[simp]:
  assumes "not_call p"
      and "not_choice p"
    shows "sterms_dom (Γ, p)"
  proof (rule accpI)
    fix y
    assume "sterms_rel y (Γ, p)"
    with assms show "sterms_dom y"
      by (cases p) (auto simp: sterms_rel.simps)
  qed

lemma sterms_termination:
  assumes "wellformed Γ"
    shows "sterms_dom (Γ, p)"
  proof -
    have sterms_rel':
      "sterms_rel = (λgq gp. (gq, gp)  {((Γ, q), (Γ', p)). Γ = Γ'  pΓ q})"
      by (rule ext)+ (auto simp: sterms_rel.simps elim: microstep.cases)

    from assms have "x. x  Wellfounded.acc {(q, p). pΓ q}"
      unfolding wellformed_def by (simp add: wf_acc_iff)
    hence "p  Wellfounded.acc {(q, p). pΓ q}" ..

    hence "(Γ, p)  Wellfounded.acc {((Γ, q), (Γ', p)). Γ = Γ'  pΓ q}"
      by (rule acc_induct) (auto intro: accI)

    thus "sterms_dom (Γ, p)" unfolding sterms_rel' accp_acc_eq .
  qed

declare sterms.psimps [simp]

lemmas sterms_psimps[simp] = sterms.psimps [OF sterms_termination]
   and sterms_pinduct = sterms.pinduct [OF sterms_termination]

lemma sterms_reflD [dest]:
  assumes "q  sterms Γ p"
      and "not_choice p" "not_call p"
    shows "q = p"
  using assms by (cases p) auto

lemma sterms_choice_disj [simp]:
  assumes "wellformed Γ"
    shows "p  sterms Γ (p1  p2) = (p  sterms Γ p1  p  sterms Γ p2)"
  using assms by (simp)

lemma sterms_no_choice [simp]:
  assumes "wellformed Γ"
    shows "p1  p2  sterms Γ p"
  using assms by induction auto

lemma sterms_not_choice [simp]:
  assumes "wellformed Γ"
      and "q  sterms Γ p"
    shows "not_choice q"
  using assms unfolding not_choice_def
  by (auto dest: sterms_no_choice)

lemma sterms_no_call [simp]:
  assumes "wellformed Γ"
    shows "call(pn)  sterms Γ p"
  using assms by induction auto

lemma sterms_not_call [simp]:
  assumes "wellformed Γ"
      and "q  sterms Γ p"
    shows "not_call q"
  using assms unfolding not_call_def
  by (auto dest: sterms_no_call)

lemma sterms_in_branch:
  assumes "wellformed Γ"
      and "p  sterms Γ (p1  p2)"
      and "p  sterms Γ p1  P"
      and "p  sterms Γ p2  P"
  shows "P"
  using assms by auto

lemma sterms_commute:
  assumes "wellformed Γ"
    shows "sterms Γ (p1  p2) = sterms Γ (p2  p1)"
  using assms by simp (rule Un_commute)

lemma sterms_not_empty:
  assumes "wellformed Γ"
    shows "sterms Γ p  {}"
  using assms
  by (induct p rule: sterms_pinduct [OF ‹wellformed Γ]) simp_all

lemma sterms_sterms [simp]:
  assumes "wellformed Γ"
    shows "(xsterms Γ p. sterms Γ x) = sterms Γ p"
  using assms by induction simp_all

lemma sterms_stermsl:
  assumes "ps  sterms Γ p"
      and "wellformed Γ"
    shows "ps  stermsl p  (pn. ps  stermsl (Γ pn))"
  using assms by (induction p rule: sterms_pinduct [OF ‹wellformed Γ]) auto

lemma stermsl_sterms [elim]:
  assumes "q  stermsl p"
      and "not_call q"
      and "wellformed Γ"
    shows "q  sterms Γ p"
  using assms by (induct p) auto

lemma sterms_stermsl_heads:
  assumes "ps  sterms Γ (Γ pn)"
      and "wellformed Γ"
    shows "pn. ps  stermsl (Γ pn)"
  proof -
    from assms have "ps  stermsl (Γ pn)  (pn'. ps  stermsl (Γ pn'))"
      by (rule sterms_stermsl)
    thus ?thesis by auto
  qed

lemma sterms_subterms [dest]:
  assumes "wellformed Γ"
      and "pn. p  subterms (Γ pn)"
      and "q  sterms Γ p"
    shows "pn. q  subterms (Γ pn)"
  using assms by (induct p) auto

lemma no_microsteps_sterms_refl:
  assumes "wellformed Γ"
  shows "(¬(q. pΓ q)) = (sterms Γ p = {p})"
  proof (cases p)
    fix p1 p2
    assume "p = p1  p2"
    from ‹wellformed Γ have "p1  p2  sterms Γ (p1  p2)" by simp
    hence "sterms Γ (p1  p2)  {p1  p2}" by auto
    moreover have "q. (p1  p2)Γ q" by auto
    ultimately show ?thesis
      using p = p1  p2 by simp
  next
    fix pn
    assume "p = call(pn)"
    from ‹wellformed Γ have "call(pn)  sterms Γ (call(pn))" by simp
    hence "sterms Γ (call(pn))  {call(pn)}" by auto
    moreover have "q. (call(pn))Γ q" by auto
    ultimately show ?thesis
      using p = call(pn) by simp
  qed simp_all

lemma sterms_maximal [elim]:
  assumes "wellformed Γ"
      and "q  sterms Γ p"
    shows "sterms Γ q = {q}"
  using assms by (cases q) auto

lemma microstep_rtranscl_equal:
  assumes "not_call p"
      and "not_choice p"
      and "pΓ* q"
    shows "q = p"
  using assms(3) proof (rule converse_rtranclpE)
    fix p'
    assume "pΓ p'"
    with assms(1-2) show "q = p"
      by (cases p) simp_all
  qed simp

lemma microstep_rtranscl_singleton [simp]:
  assumes "not_call p"
      and "not_choice p"
    shows "{q. pΓ* q  sterms Γ q = {q}} = {p}"
  proof (rule set_eqI)
    fix p'
    show "(p'  {q. pΓ* q  sterms Γ q = {q}}) = (p'  {p})"
    proof
      assume "p'  {q. pΓ* q  sterms Γ q = {q}}"
      hence "(microstep Γ)** p p'" and "sterms Γ p' = {p'}" by auto
      from this(1) have "p' = p"
      proof (rule converse_rtranclpE)
        fix q assume "pΓ q"
        with ‹not_call p and ‹not_choice p have False
          by (cases p) auto
        thus "p' = p" ..
      qed simp
      thus "p'  {p}" by simp
    next
      assume "p'  {p}"
      hence "p' = p" ..
      with ‹not_call p and ‹not_choice p show "p'  {q. pΓ* q  sterms Γ q = {q}}"
        by (cases p) simp_all
    qed
  qed

theorem sterms_maximal_microstep:
  assumes "wellformed Γ"
    shows "sterms Γ p = {q. pΓ* q  ¬(q'. qΓ q')}"
  proof
    from ‹wellformed Γ have "sterms Γ p  {q. pΓ* q  sterms Γ q = {q}}"
    proof induction
     fix p1 p2
     assume IH1: "sterms Γ p1  {q. p1Γ* q  sterms Γ q = {q}}"
        and IH2: "sterms Γ p2  {q. p2Γ* q  sterms Γ q = {q}}"
     have "sterms Γ p1  {q. (p1  p2)Γ* q  sterms Γ q = {q}}"
     proof
       fix p'
       assume "p'  sterms Γ p1"
       with IH1 have "p1Γ* p'" by auto
       moreover have "(p1  p2)Γ p1" ..
       ultimately have "(p1  p2)Γ* p'"
         by - (rule converse_rtranclp_into_rtranclp)
       moreover from ‹wellformed Γ and p'  sterms Γ p1 have "sterms Γ p' = {p'}" ..
       ultimately show "p'  {q. (p1  p2)Γ* q  sterms Γ q = {q}}"
         by simp
     qed
     moreover have "sterms Γ p2  {q. (p1  p2)Γ* q  sterms Γ q = {q}}"
     proof
       fix p'
       assume "p'  sterms Γ p2"
       with IH2 have "p2Γ* p'" and "sterms Γ p' = {p'}" by auto
       moreover have "(p1  p2)Γ p2" ..
       ultimately have "(p1  p2)Γ* p'"
         by - (rule converse_rtranclp_into_rtranclp)
       with ‹sterms Γ p' = {p'} show "p'  {q. (p1  p2)Γ* q  sterms Γ q = {q}}"
         by simp
     qed
     ultimately show "sterms Γ (p1  p2)  {q. (p1  p2)Γ* q  sterms Γ q = {q}}"
       using ‹wellformed Γ by simp
    next
      fix pn
      assume IH: "sterms Γ (Γ pn)  {q. Γ pnΓ* q  sterms Γ q = {q}}"
      show "sterms Γ (call(pn))  {q. (call(pn))Γ* q  sterms Γ q = {q}}"
      proof
        fix p'
        assume "p'  sterms Γ (call(pn))"
        with ‹wellformed Γ have "p'  sterms Γ (Γ pn)" by simp
        with IH have "Γ pnΓ* p'" and "sterms Γ p' = {p'}" by auto
        note this(1)
        moreover have "(call(pn))Γ Γ pn" by simp
        ultimately have "(call(pn))Γ* p'"
          by - (rule converse_rtranclp_into_rtranclp)
        with ‹sterms Γ p' = {p'} show "p'  {q. (call(pn))Γ* q  sterms Γ q = {q}}"
          by simp
      qed
    qed simp_all
    with ‹wellformed Γ show "sterms Γ p  {q. pΓ* q  ¬(q'. qΓ q')}"
      by (simp only: no_microsteps_sterms_refl)
  next
    from ‹wellformed Γ have "{q. pΓ* q  sterms Γ q = {q}}  sterms Γ p"
    proof (induction)
      fix p1 p2
      assume IH1: "{q. p1Γ* q  sterms Γ q = {q}}  sterms Γ p1"
         and IH2: "{q. p2Γ* q  sterms Γ q = {q}}  sterms Γ p2"
      show "{q. (p1  p2)Γ* q  sterms Γ q = {q}}  sterms Γ (p1  p2)"
      proof (rule, drule CollectD, erule conjE)
        fix q'
        assume "(p1  p2)Γ* q'"
           and "sterms Γ q' = {q'}"
        with ‹wellformed Γ have "(p1  p2)Γ+ q'"          
          by (auto dest!: rtranclpD sterms_no_choice)
        hence "p1Γ* q'  p2Γ* q'"
          by (auto dest: tranclpD)
        thus "q'  sterms Γ (p1  p2)"
        proof
          assume "p1Γ* q'"
          with IH1 and ‹sterms Γ q' = {q'} have "q'  sterms Γ p1" by auto
          with ‹wellformed Γ show ?thesis by auto
        next
          assume "p2Γ* q'"
          with IH2 and ‹sterms Γ q' = {q'} have "q'  sterms Γ p2" by auto
          with ‹wellformed Γ show ?thesis by auto
        qed
      qed
    next
      fix pn
      assume IH: "{q. Γ pnΓ* q  sterms Γ q = {q}}  sterms Γ (Γ pn)"
      show   "{q. (call(pn))Γ* q  sterms Γ q = {q}}  sterms Γ (call(pn))"
      proof (rule, drule CollectD, erule conjE)
        fix q'
        assume "(call(pn))Γ* q'"
           and "sterms Γ q' = {q'}"
        with ‹wellformed Γ have "(call(pn))Γ+ q'"
          by (auto dest!: rtranclpD sterms_no_call)
        moreover have "(call(pn))Γ Γ pn" ..
        ultimately have "Γ pnΓ* q'"
          by (auto dest!: tranclpD)
        with ‹sterms Γ q' = {q'} and IH have "q'  sterms Γ (Γ pn)" by auto
        with ‹wellformed Γ show "q'  sterms Γ (call(pn))" by simp
      qed
    qed simp_all
    with ‹wellformed Γ show "{q. pΓ* q  ¬(q'. qΓ q')}  sterms Γ p"
    by (simp only: no_microsteps_sterms_refl)
  qed

subsection "Derivative terms "

text ‹
  The derivatives of a term are those @{term sterm}s potentially reachable by taking a
  transition, relative to a wellformed process specification Γ›. These terms
  overapproximate the reachable sterms, since the truth of guards is not considered.
›

function (domintros) dterms
  :: "('s, 'm, 'p, 'l) seqp_env  ('s, 'm, 'p, 'l) seqp  ('s, 'm, 'p, 'l) seqp set"
  where
    "dterms Γ ({l}g p)                     = sterms Γ p"
  | "dterms Γ ({l}u p)                     = sterms Γ p"
  | "dterms Γ (p1  p2)                     = dterms Γ p1  dterms Γ p2"
  | "dterms Γ ({l}unicast(sip, smsg).p  q)  = sterms Γ p  sterms Γ q"
  | "dterms Γ ({l}broadcast(smsg). p)        = sterms Γ p"
  | "dterms Γ ({l}groupcast(sips, smsg). p)  = sterms Γ p"
  | "dterms Γ ({l}send(smsg).p)              = sterms Γ p"
  | "dterms Γ ({l}deliver(sdata).p)          = sterms Γ p"
  | "dterms Γ ({l}receive(umsg).p)           = sterms Γ p"
  | "dterms Γ (call(pn))                     = dterms Γ (Γ pn)"
  by pat_completeness auto

lemma dterms_dom_basic [simp]:
  assumes "not_call p"
      and "not_choice p"
    shows "dterms_dom (Γ, p)"
  proof (rule accpI)
    fix y
    assume "dterms_rel y (Γ, p)"
    with assms show "dterms_dom y"
      by (cases p) (auto simp: dterms_rel.simps)
  qed

lemma dterms_termination:
  assumes "wellformed Γ"
    shows "dterms_dom (Γ, p)"
  proof -
    have dterms_rel': "dterms_rel = (λgq gp. (gq, gp)  {((Γ, q), (Γ', p)). Γ = Γ'  pΓ q})"
      by (rule ext)+ (auto simp: dterms_rel.simps elim: microstep.cases)
    from ‹wellformed(Γ) have "x. x  Wellfounded.acc {(q, p). pΓ q}"
      unfolding wellformed_def by (simp add: wf_acc_iff)
    hence "p  Wellfounded.acc {(q, p). pΓ q}" ..
    hence "(Γ, p)  Wellfounded.acc {((Γ, q), Γ', p). Γ = Γ'  pΓ q}"
      by (rule acc_induct) (auto intro: accI)
    thus "dterms_dom (Γ, p)"
      unfolding dterms_rel' by (subst accp_acc_eq)
  qed

lemmas dterms_psimps [simp] = dterms.psimps [OF dterms_termination]
   and dterms_pinduct = dterms.pinduct [OF dterms_termination]

lemma sterms_after_dterms [simp]:
  assumes "wellformed Γ"
  shows "(xdterms Γ p. sterms Γ x) = dterms Γ p"
  using assms by (induction p) simp_all

lemma sterms_before_dterms [simp]:
  assumes "wellformed Γ"
  shows "(xsterms Γ p. dterms Γ x) = dterms Γ p"
  using assms by (induction p) simp_all

lemma dterms_choice_disj [simp]:
  assumes "wellformed Γ"
    shows "p  dterms Γ (p1  p2) = (p  dterms Γ p1  p  dterms Γ p2)"
  using assms by (simp)

lemma dterms_in_branch:
  assumes "wellformed Γ"
      and "p  dterms Γ (p1  p2)"
      and "p  dterms Γ p1  P"
      and "p  dterms Γ p2  P"
  shows "P"
  using assms by auto

lemma dterms_no_choice:
  assumes "wellformed Γ"
    shows "p1  p2  dterms Γ p"
  using assms by induction simp_all

lemma dterms_not_choice [simp]:
  assumes "wellformed Γ"
      and "q  dterms Γ p"
    shows "not_choice q"
  using assms unfolding not_choice_def
  by (auto dest: dterms_no_choice)

lemma dterms_no_call:
  assumes "wellformed Γ"
    shows "call(pn)  dterms Γ p"
  using assms by induction simp_all

lemma dterms_not_call [simp]:
  assumes "wellformed Γ"
      and "q  dterms Γ p"
    shows "not_call q"
  using assms unfolding not_call_def
  by (auto dest: dterms_no_call)

lemma dterms_subterms:
  assumes wf: "wellformed Γ"
      and "pn. p  subterms (Γ pn)"
      and "q  dterms Γ p"
    shows "pn. q  subterms (Γ pn)"
  using assms
  proof (induct p)
       fix p1 p2
    assume IH1: "pn. p1  subterms (Γ pn)  q  dterms Γ p1  pn. q  subterms (Γ pn)"
       and IH2: "pn. p2  subterms (Γ pn)  q  dterms Γ p2  pn. q  subterms (Γ pn)"
       and *: "pn. p1  p2  subterms (Γ pn)"
       and "q  dterms Γ (p1  p2)"
    from * obtain pn where "p1  p2  subterms (Γ pn)"
      by auto
    hence "p1  subterms (Γ pn)" and "p2  subterms (Γ pn)"
      by auto
    from q  dterms Γ (p1  p2) wf have "q  dterms Γ p1  q  dterms Γ p2"
      by auto
    thus "pn. q  subterms (Γ pn)"
      proof
        assume "q  dterms Γ p1"
        with p1  subterms (Γ pn) show ?thesis
          by (auto intro: IH1)
      next
        assume "q  dterms Γ p2"
        with p2  subterms (Γ pn) show ?thesis
          by (auto intro: IH2)
      qed
  qed auto

text ‹
  Note that the converse of @{thm dterms_subterms} is not true because @{term dterm}s are an
  over-approximation; i.e., we cannot show, in general, that guards return a non-empty set
  of post-states.
›

subsection "Control terms "

text ‹
  The control terms of a process specification @{term Γ} are those subterms from which
  transitions are directly possible. We can omit @{term "call(pn)"} terms, since
  the root terms of all processes are considered, and also @{term "p1  p2"} terms
  since they effectively combine the transitions of the subterms @{term p1} and
  @{term p2}.

  It will be shown that only the control terms, rather than all subterms, need be
  considered in invariant proofs.
›

inductive_set
  cterms :: "('s, 'm, 'p, 'l) seqp_env  ('s, 'm, 'p, 'l) seqp set"
  for Γ :: "('s, 'm, 'p, 'l) seqp_env"
where
    ctermsSI[intro]: "p  sterms Γ (Γ pn)  p  cterms Γ"
  | ctermsDI[intro]: " pp  cterms Γ; p  dterms Γ pp   p  cterms Γ"

lemma cterms_not_choice [simp]:
  assumes "wellformed Γ"
      and "p  cterms Γ"
    shows "not_choice p"
  using assms
  proof (cases p)
    case CHOICE from p  cterms Γ show ?thesis
      using ‹wellformed Γ by cases simp_all
  qed simp_all

lemma cterms_no_choice [simp]:
  assumes "wellformed Γ"
    shows "p1  p2  cterms Γ"
  using assms by (auto dest: cterms_not_choice)

lemma cterms_not_call [simp]:
  assumes "wellformed Γ"
      and "p  cterms Γ"
    shows "not_call p"
  using assms
  proof (cases p)
    case CALL from p  cterms Γ show ?thesis
      using ‹wellformed Γ by cases simp_all
  qed simp_all

lemma cterms_no_call [simp]:
  assumes "wellformed Γ"
    shows "call(pn)  cterms Γ"
  using assms by (auto dest: cterms_not_call)

lemma sterms_cterms [elim]:
  assumes "p  cterms Γ"
      and "q  sterms Γ p"
      and "wellformed Γ"
    shows "q  cterms Γ"
  using assms by - (cases p, auto)

lemma dterms_cterms [elim]:
  assumes "p  cterms Γ"
      and "q  dterms Γ p"
      and "wellformed Γ"
    shows "q  cterms Γ"
  using assms by (cases p) auto

lemma derivs_in_cterms [simp]:
  "l f p. {l}f p  cterms Γ                             sterms Γ p  cterms Γ"
  "l f p. {l}f p  cterms Γ                            sterms Γ p  cterms Γ"
  "l fip fmsg q p. {l}unicast(fip, fmsg). p  q  cterms Γ
                             sterms Γ p  cterms Γ  sterms Γ q  cterms Γ"
  "l fmsg p.      {l}broadcast(fmsg).p  cterms Γ        sterms Γ p  cterms Γ"
  "l fips fmsg p. {l}groupcast(fips, fmsg).p  cterms Γ  sterms Γ p  cterms Γ"
  "l fmsg p.      {l}send(fmsg).p  cterms Γ             sterms Γ p  cterms Γ"
  "l fdata p.     {l}deliver(fdata).p  cterms Γ         sterms Γ p  cterms Γ"
  "l fmsg p.      {l}receive(fmsg).p  cterms Γ          sterms Γ p  cterms Γ"
  by (auto simp: dterms.psimps)

subsection "Local control terms"

text ‹
  We introduce a `local' version of @{term cterms} that does not step through calls and,
  thus, that is defined independently of a process specification @{term Γ}.
  This allows an alternative, terminating characterisation of cterms as a set of
  subterms. Including @{term "call(pn)"}s in the set makes for a simpler relation with
  @{term "stermsl"}, even if they must be filtered out for the desired characterisation.
›

function
  ctermsl :: "('s, 'm, 'p, 'l) seqp  ('s, 'm, 'p , 'l) seqp set"
where
    "ctermsl ({l}g p)                     = insert ({l}g p)  (ctermsl p)"
  | "ctermsl ({l}u p)                     = insert ({l}u p)  (ctermsl p)"
  | "ctermsl ({l}unicast(sip, smsg). p  q) = insert ({l}unicast(sip, smsg). p  q)
                                                                      (ctermsl p  ctermsl q)"
  | "ctermsl ({l}broadcast(smsg). p)       = insert ({l}broadcast(smsg). p)       (ctermsl p)"
  | "ctermsl ({l}groupcast(sips, smsg). p)  = insert ({l}groupcast(sips, smsg). p) (ctermsl p)"
  | "ctermsl ({l}send(smsg). p)            = insert ({l}send(smsg). p)            (ctermsl p)"
  | "ctermsl ({l}deliver(sdata). p)        = insert ({l}deliver(sdata). p)        (ctermsl p)"
  | "ctermsl ({l}receive(umsg). p)         = insert ({l}receive(umsg). p)         (ctermsl p)"
  | "ctermsl (p1  p2)                    = ctermsl p1  ctermsl p2"
  | "ctermsl (call(pn))                   = {call(pn)}"
  by pat_completeness auto
  termination by (relation "measure(size)") (auto dest: stermsl_nobigger)

lemmas ctermsl_induct =
  ctermsl.induct [case_names GUARD ASSIGN UCAST BCAST GCAST
                             SEND DELIVER RECEIVE CHOICE CALL]

lemma ctermsl_refl [intro]: "not_choice p  p  ctermsl p"
  by (cases p) auto

lemma ctermsl_subterms:
  "ctermsl p = {q. q  subterms p  not_choice q }" (is "?lhs = ?rhs")
  proof
    show "?lhs  ?rhs" by (induct p, auto) next
    show "?rhs  ?lhs" by (induct p, auto)
  qed

lemma ctermsl_trans [elim]:
  assumes "q  ctermsl p"
      and "r  ctermsl q"
    shows "r  ctermsl p"
  using assms
  proof (induction p rule: ctermsl_induct)
    case (CHOICE p1 p2)
      have "(q  ctermsl p1)  (q  ctermsl p2)"
        using CHOICE.prems(1) by simp
      hence "r  ctermsl p1  r  ctermsl p2"
      proof (rule disj_forward)
        assume "q  ctermsl p1"
        thus "r  ctermsl p1" using r  ctermsl q by (rule CHOICE.IH)
      next
        assume "q  ctermsl p2"
        thus "r  ctermsl p2" using r  ctermsl q by (rule CHOICE.IH)
      qed
      thus "r  ctermsl (p1  p2)" by simp
    qed auto

lemma ctermsl_ex_trans [elim]:
  assumes "q  ctermsl p. r  ctermsl q"
    shows "r  ctermsl p"
  using assms by auto

lemma call_ctermsl_empty [elim]:
  " p  ctermsl p'; not_call p   not_call p'"
  unfolding not_call_def by (cases p) auto

lemma stermsl_ctermsl_choice1 [simp]:
  assumes "q  stermsl p1"
    shows "q  ctermsl (p1  p2)"
  using assms by (induction p1) auto

lemma stermsl_ctermsl_choice2 [simp]:
  assumes "q  stermsl p2"
    shows "q  ctermsl (p1  p2)"
  using assms by (induction p2) auto

lemma stermsl_ctermsl [elim]:
  assumes "q  stermsl p"
    shows "q  ctermsl p"
  using assms
  proof (cases p)
    case (CHOICE p1 p2)
    hence "q  stermsl (p1  p2)" using assms by simp
    hence "q  stermsl p1  q  stermsl p2" by simp
    hence "q  ctermsl (p1  p2)" by (rule) (simp_all del: ctermsl.simps)
    thus  "q  ctermsl p" using CHOICE by simp
  qed simp_all

lemma stermsl_after_ctermsl [simp]:
  "(xctermsl p. stermsl x) = ctermsl p"
  by (induct p) auto

lemma stermsl_before_ctermsl [simp]:
  "(xstermsl p. ctermsl x) = ctermsl p"
  by (induct p) simp_all

lemma ctermsl_no_choice: "p1  p2  ctermsl p"
  by (induct p) simp_all

lemma ctermsl_ex_stermsl: "q  ctermsl p  psstermsl p. q  ctermsl ps"
  by (induct p) auto

lemma dterms_ctermsl [intro]:
  assumes "q  dterms Γ p"
      and "wellformed Γ"
    shows "q  ctermsl p  (pn. q  ctermsl (Γ pn))"
  using assms(1-2)
  proof (induction p rule: dterms_pinduct [OF ‹wellformed Γ])
    fix Γ l fg p
    assume "q  dterms Γ ({l}fg p)"
       and "wellformed Γ"
    hence "q  sterms Γ p" by simp
    hence "q  stermsl p  (pn. q  stermsl (Γ pn))"
      using ‹wellformed Γ  by (rule sterms_stermsl)
    thus "q  ctermsl ({l}fg p)  (pn. q  ctermsl (Γ pn))"
    proof
      assume "q  stermsl p"
      hence "q  ctermsl p" by (rule stermsl_ctermsl)
      hence "q  ctermsl ({l}fg p)" by simp
      thus ?thesis ..
    next
      assume "pn. q  stermsl (Γ pn)"
      then obtain pn where "q  stermsl (Γ pn)" by auto
      hence "q  ctermsl (Γ pn)" by (rule stermsl_ctermsl)
      hence "pn. q  ctermsl (Γ pn)" ..
      thus ?thesis ..
    qed
  next
    fix Γ p1 p2
    assume "q  dterms Γ (p1  p2)"
       and IH1: " q  dterms Γ p1; wellformed Γ   q  ctermsl p1  (pn. q  ctermsl (Γ pn))"
       and IH2: " q  dterms Γ p2; wellformed Γ   q  ctermsl p2  (pn. q  ctermsl (Γ pn))"
       and "wellformed Γ"
    thus "q  ctermsl (p1  p2)  (pn. q  ctermsl (Γ pn))"
      by auto
  next
    fix Γ pn
    assume "q  dterms Γ (call(pn))"
       and "wellformed Γ"
       and " q  dterms Γ (Γ pn); wellformed Γ   q  ctermsl (Γ pn)  (pn. q  ctermsl (Γ pn))"
    thus "q  ctermsl (call(pn))  (pn. q  ctermsl (Γ pn))"
      by auto
  qed (simp_all, (metis sterms_stermsl stermsl_ctermsl)+)

lemma ctermsl_cterms [elim]:
  assumes "q  ctermsl p"
      and "not_call q"
      and "sterms Γ p  cterms Γ"
      and "wellformed Γ"
    shows "q  cterms Γ"
  using assms by (induct p rule: ctermsl.induct) auto

subsection "Local deriviative terms"

text ‹
  We define local @{term "dterm"}s for use in the theorem that relates @{term "cterms"}
  and sets of @{term "ctermsl"}.
›

function dtermsl
  :: "('s, 'm, 'p, 'l) seqp  ('s, 'm, 'p, 'l) seqp set"
  where
    "dtermsl ({l}fg p)                     = stermsl p"
  | "dtermsl ({l}fa p)                     = stermsl p"
  | "dtermsl (p1  p2)                      = dtermsl p1  dtermsl p2"
  | "dtermsl ({l}unicast(fip, fmsg).p  q)  = stermsl p  stermsl q"
  | "dtermsl ({l}broadcast(fmsg). p)         = stermsl p"
  | "dtermsl ({l}groupcast(fips, fmsg). p)   = stermsl p"
  | "dtermsl ({l}send(fmsg).p)               = stermsl p"
  | "dtermsl ({l}deliver(fdata).p)           = stermsl p"
  | "dtermsl ({l}receive(fmsg).p)            = stermsl p"
  | "dtermsl (call(pn))                      = {}"
  by pat_completeness auto
  termination by (relation "measure(size)") (auto dest: stermsl_nobigger)

lemma stermsl_after_dtermsl [simp]:
  shows "(xdtermsl p. stermsl x) = dtermsl p"
  by (induct p) simp_all

lemma stermsl_before_dtermsl [simp]:
  "(xstermsl p. dtermsl x) = dtermsl p"
  by (induct p) simp_all

lemma dtermsl_no_choice [simp]: "p1  p2  dtermsl p"
  by (induct p) simp_all

lemma dtermsl_choice_disj [simp]:
  "p  dtermsl (p1  p2) = (p  dtermsl p1  p  dtermsl p2)"
  by simp

lemma dtermsl_in_branch [elim]:
  "p  dtermsl (p1  p2); p  dtermsl p1  P; p  dtermsl p2  P  P"
  by auto

lemma ctermsl_dtermsl [elim]:
  assumes "q  dtermsl p"
    shows "q  ctermsl p"
  using assms by (induct p) (simp_all, (metis stermsl_ctermsl)+)

lemma dtermsl_dterms [elim]:
  assumes "q  dtermsl p"
      and "not_call q"
      and "wellformed Γ"
    shows "q  dterms Γ p"
  using assms
  using assms by (induct p) (simp_all, (metis stermsl_sterms)+)

lemma ctermsl_stermsl_or_dtermsl:
  assumes "q  ctermsl p"
    shows "q  stermsl p  (p'dtermsl p. q  ctermsl p')"
  using assms by (induct p) (auto dest: ctermsl_ex_stermsl)

lemma dtermsl_add_stermsl_beforeD:
  assumes "q  dtermsl p"
    shows "psstermsl p. q  dtermsl ps"
  proof -
    from assms have "q  (xstermsl p. dtermsl x)" by auto
    thus ?thesis
      by (rule UN_E) auto
  qed

lemma call_dtermsl_empty [elim]:
 "q  dtermsl p  not_call p"
  by (cases p) simp_all

subsection "More properties of control terms"

text ‹
  We now show an alternative definition of @{term "cterms"} based on sets of local control
  terms. While the original definition has convenient induction and simplification rules,
  useful for proving properties like cterms\_includes\_sterms\_of\_seq\_reachable, this
  definition makes it easier to systematically generate the set of control terms of a
  process specification.
›

theorem cterms_def':
  assumes wfg: "wellformed Γ"
    shows "cterms Γ = { p |p pn. p  ctermsl (Γ pn)  not_call p }"
          (is "_ = ?ctermsl_set")
  proof (rule iffI [THEN set_eqI])
    fix p
    assume "p  cterms Γ"
    thus "p  ?ctermsl_set"
    proof (induction p)
      fix p pn
      assume "p  sterms Γ (Γ pn)"
      then obtain pn' where "p  stermsl (Γ pn')" using wfg
        by (blast dest: sterms_stermsl_heads)
      hence "p  ctermsl (Γ pn')" ..
      moreover from p  sterms Γ (Γ pn) wfg have "not_call p" by simp
      ultimately show "p  ?ctermsl_set" by auto
    next
      fix pp p
      assume "pp  cterms Γ"
         and IH: "pp  ?ctermsl_set"
         and *: "p  dterms Γ pp"
      from * have "p  ctermsl pp  (pn. p  ctermsl (Γ pn))"
        using wfg by (rule dterms_ctermsl)
      hence "pn. p  ctermsl (Γ pn)"
        proof
          assume "p  ctermsl pp"
          from pp  cterms Γ and IH obtain pn' where "pp  ctermsl (Γ pn')"
            by auto
          with p  ctermsl pp have "p  ctermsl (Γ pn')" by auto
          thus "pn. p  ctermsl (Γ pn)" ..
        qed -
      moreover from p  dterms Γ pp wfg have "not_call p" by simp
      ultimately show "p  ?ctermsl_set" by auto
    qed
  next
    fix p
    assume "p  ?ctermsl_set"
    then obtain pn where *: "p  ctermsl (Γ pn)" and "not_call p" by auto
    from * have "p  stermsl (Γ pn)  (p'dtermsl (Γ pn). p  ctermsl p')"
      by (rule ctermsl_stermsl_or_dtermsl)
    thus "p  cterms Γ"
    proof
      assume "p  stermsl (Γ pn)"
      hence "p  sterms Γ (Γ pn)" using ‹not_call p wfg ..
      thus "p  cterms Γ" ..
    next
      assume "p'dtermsl (Γ pn). p  ctermsl p'"
      then obtain p' where p'1: "p'  dtermsl (Γ pn)"
                       and p'2: "p  ctermsl p'" ..
      from p'2 and ‹not_call p have "not_call p'" ..
      from p'1 obtain ps where ps1: "ps  stermsl (Γ pn)"
                           and ps2: "p'  dtermsl ps"
        by (blast dest: dtermsl_add_stermsl_beforeD)
      from ps2 have "not_call ps" ..
      with ps1 have "ps  cterms Γ" using wfg by auto
      with p'  dtermsl ps and ‹not_call p' have "p'  cterms Γ" using wfg by auto
      hence "sterms Γ p'  cterms Γ" using wfg by auto
      with p  ctermsl p' ‹not_call p show "p  cterms Γ" using wfg ..
    qed
  qed

lemma ctermsE [elim]:
  assumes "wellformed Γ"
      and "p  cterms Γ"
  obtains pn where "p  ctermsl (Γ pn)"
               and "not_call p"
  using assms(2) unfolding cterms_def' [OF assms(1)] by auto

corollary cterms_subterms:
  assumes "wellformed Γ"
    shows "cterms Γ = {p|p pn. psubterms (Γ pn)  not_call p  not_choice p}"
  by (subst cterms_def' [OF assms(1)], subst ctermsl_subterms) auto

lemma subterms_in_cterms [elim]:
  assumes "wellformed Γ"
      and "psubterms (Γ pn)"
      and "not_call p"
      and "not_choice p"
    shows "p  cterms Γ"
  using assms unfolding cterms_subterms [OF ‹wellformed Γ] by auto

lemma subterms_stermsl_ctermsl:
  assumes "q  subterms p"
      and "r  stermsl q"
    shows "r  ctermsl p"
  using assms
  proof (induct p)
    fix p1 p2
    assume IH1: "q  subterms p1  r  stermsl q  r  ctermsl p1"
       and IH2: "q  subterms p2  r  stermsl q  r  ctermsl p2"
       and *: "q  subterms (p1  p2)"
       and "r  stermsl q"
    from * have "q  {p1  p2}  subterms p1  subterms p2" by simp
    thus "r  ctermsl (p1  p2)"
    proof (elim UnE)
      assume "q  {p1  p2}" with r  stermsl q show ?thesis
      by simp (metis stermsl_ctermsl)
    next
      assume "q  subterms p1" hence "r  ctermsl p1" using r  stermsl q by (rule IH1)
      thus ?thesis by simp
    next
      assume "q  subterms p2" hence "r  ctermsl p2" using r  stermsl q by (rule IH2)
      thus ?thesis by simp
    qed
  qed auto

lemma subterms_sterms_cterms:
  assumes wf: "wellformed Γ"
      and "p  subterms (Γ pn)"
    shows "sterms Γ p  cterms Γ"
  using assms(2)
  proof (induct p)
    fix p
    assume "call(p)  subterms (Γ pn)"
    from wf have "sterms Γ (call(p)) = sterms Γ (Γ p)" by simp
      thus "sterms Γ (call(p))  cterms Γ" by auto
  next
    fix p1 p2
    assume IH1: "p1  subterms (Γ pn)  sterms Γ p1  cterms Γ"
       and IH2: "p2  subterms (Γ pn)  sterms Γ p2  cterms Γ"
       and *: "p1  p2  subterms (Γ pn)"
    from * have "p1  subterms (Γ pn)" by auto
    hence "sterms Γ p1  cterms Γ" by (rule IH1)
    moreover from * have "p2  subterms (Γ pn)" by auto
      hence "sterms Γ p2  cterms Γ" by (rule IH2)
    ultimately show "sterms Γ (p1  p2 )  cterms Γ" using wf by simp
  qed (auto elim!: subterms_in_cterms [OF ‹wellformed Γ])

lemma subterms_sterms_in_cterms:
  assumes "wellformed Γ"
      and "p  subterms (Γ pn)"
      and "q  sterms Γ p"
    shows "q  cterms Γ"
  using assms
  by (auto dest!: subterms_sterms_cterms [OF ‹wellformed Γ])

end

Theory AWN_Labels

(*  Title:       AWN_Labels.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Labelling sequential processes"

theory AWN_Labels
imports AWN AWN_Cterms
begin

subsection "Labels "

text ‹
  Labels serve two main purposes. They allow the substitution of @{term sterm}s in
  @{term invariant} proofs. They also allow the strengthening (control state dependent)
  of invariants.
›

function (domintros) labels
  :: "('s, 'm, 'p, 'l) seqp_env  ('s, 'm, 'p, 'l) seqp  'l set"
  where
    "labels Γ ({l}fg p)                     = {l}"
  | "labels Γ ({l}fa p)                     = {l}"
  | "labels Γ (p1  p2)                      = labels Γ p1  labels Γ p2"
  | "labels Γ ({l}unicast(fip, fmsg).p  q)  = {l}"
  | "labels Γ ({l}broadcast(fmsg). p)         = {l}"
  | "labels Γ ({l}groupcast(fips, fmsg). p)   = {l}"
  | "labels Γ ({l}send(fmsg).p)               = {l}"
  | "labels Γ ({l}deliver(fdata).p)           = {l}"
  | "labels Γ ({l}receive(fmsg).p)            = {l}"
  | "labels Γ (call(pn))                      = labels Γ (Γ pn)"
  by pat_completeness auto

lemma labels_dom_basic [simp]:
  assumes "not_call p"
      and "not_choice p"
  shows "labels_dom (Γ, p)"
  proof (rule accpI)
    fix y
    assume "labels_rel y (Γ, p)"
    with assms show "labels_dom y"
      by (cases p) (auto simp: labels_rel.simps)
  qed

lemma labels_termination:
    fixes Γ p
  assumes "wellformed(Γ)"
    shows "labels_dom (Γ, p)"
  proof -
    have labels_rel': "labels_rel = (λgq gp. (gq, gp)  {((Γ, q), (Γ', p)). Γ = Γ'  pΓ q})"
      by (rule ext)+ (auto simp: labels_rel.simps intro: microstep.intros elim: microstep.cases)
    from ‹wellformed(Γ) have "x. x  Wellfounded.acc {(q, p). pΓ q}"
      unfolding wellformed_def by (simp add: wf_acc_iff)
    hence "p  Wellfounded.acc {(q, p). pΓ q}" ..
    hence "(Γ, p)  Wellfounded.acc {((Γ, q), Γ', p). Γ = Γ'  pΓ q}"
      by (rule acc_induct) (auto intro: accI)
    thus "labels_dom (Γ, p)"
      unfolding labels_rel' by (subst accp_acc_eq)
  qed

declare labels.psimps[simp]

lemmas labels_pinduct = labels.pinduct [OF labels_termination]
   and labels_psimps[simp] = labels.psimps [OF labels_termination]

lemma labels_not_empty:
    fixes Γ p
  assumes "wellformed Γ"
    shows "labels Γ p  {}"
   by (induct p rule: labels_pinduct [OF ‹wellformed Γ]) simp_all

lemma has_label [dest]:
    fixes Γ p
  assumes "wellformed Γ"
    shows "l. l  labels Γ p"
  using labels_not_empty [OF assms] by auto

lemma singleton_labels [simp]:
  "Γ l l' f p.          l  labels Γ ({l'}f p)                       = (l = l')"
  "Γ l l' f p.          l  labels Γ ({l'}f p)                      = (l = l')"
  "Γ l l' fip fmsg p q. l  labels Γ ({l'}unicast(fip, fmsg).p  q)  = (l = l')"
  "Γ l l' fmsg p.       l  labels Γ ({l'}broadcast(fmsg). p)         = (l = l')"
  "Γ l l' fips fmsg p.  l  labels Γ ({l'}groupcast(fips, fmsg). p)   = (l = l')"
  "Γ l l' fmsg p.       l  labels Γ ({l'}send(fmsg).p)               = (l = l')"
  "Γ l l' fdata p.      l  labels Γ ({l'}deliver(fdata).p)           = (l = l')"
  "Γ l l' fmsg p.       l  labels Γ ({l'}receive(fmsg).p)            = (l = l')"
  by auto

lemma in_labels_singletons [dest!]:
  "Γ l l' f p.          l  labels Γ ({l'}f p)                        l = l'"
  "Γ l l' f p.          l  labels Γ ({l'}f p)                       l = l'"
  "Γ l l' fip fmsg p q. l  labels Γ ({l'}unicast(fip, fmsg).p  q)   l = l'"
  "Γ l l' fmsg p.       l  labels Γ ({l'}broadcast(fmsg). p)          l = l'"
  "Γ l l' fips fmsg p.  l  labels Γ ({l'}groupcast(fips, fmsg). p)    l = l'"
  "Γ l l' fmsg p.       l  labels Γ ({l'}send(fmsg).p)                l = l'"
  "Γ l l' fdata p.      l  labels Γ ({l'}deliver(fdata).p)            l = l'"
  "Γ l l' fmsg p.       l  labels Γ ({l'}receive(fmsg).p)             l = l'"
  by auto

definition
  simple_labels :: "('s, 'm, 'p, 'l) seqp_env  bool"
where
  "simple_labels Γ  pn. psubterms (Γ pn). (∃!l. labels Γ p = {l})"

lemma simple_labelsI [intro]:
  assumes "pn p. psubterms (Γ pn)  ∃!l. labels Γ p = {l}"
  shows "simple_labels Γ"
  using assms unfolding simple_labels_def by auto

text ‹
  The @{term "simple_labels Γ"} property is necessary to transfer results shown over the
  @{term "cterms"} of a process specification @{term "Γ"} to the reachable actions of
  that process.

  Consider the process @{term "{l1}send(m1). p1  {l2}send(m2). p2"}. The iteration over @{term
  "cterms Γ"} will cover the two transitions
    @{term "(l1, send m1, p1)"} and
    @{term "(l2, send m2, p2)"},
  but reachability requires the four transitions
    @{term "(l1, send m1, p1)"},
    @{term "(l1, send m2, p2)"},
    @{term "(l2, send m1, p1)"}, and
    @{term "(l2, send m2, p2)"}.

  In a simply labelled process, the former is sufficient to show the latter, since
  @{term "l1 = l2"}.

  This requirement seems really only to be restrictive for processes where a @{term "call(pn)"}
  occurs as a direct subterm of a choice operator. Consider, for instance, @{term "({l1}e p) 
  call(pn)"}. Here @{term "l1"} must equal the label of @{term "Γ(pn)"}, which can then not be
  distinguished from any other subterm that calls @{term "pn"} in any other process.

  This limitation stems from the fact that the "call points" of a process are effectively treated as
  the root of the called process. This is by design; we try to treat call sites as "syntactic
  pastings" of process terms, giving rise, conceptually, to an infinite tree structure. But this
  prejudices the alternative view that process calls are used as "join points" of "process threads",
  in complement to the "fork points" of the @{term "p1  p2"} operator.
›

lemma simple_labels_in_sterms:
    fixes Γ l p
  assumes "simple_labels Γ"
      and "wellformed Γ"
      and "pn. psubterms (Γ pn)"
      and "llabels Γ p"
    shows "p'sterms Γ p. llabels Γ p'"
  using assms
  proof (induct p rule: labels_pinduct [OF ‹wellformed Γ])
    fix Γ p1 p2
    assume sl: "simple_labels Γ"
       and wf: "wellformed Γ"
       and IH1: " simple_labels Γ; wellformed Γ;
                   pn. p1  subterms (Γ pn); l  labels Γ p1 
                  p'sterms Γ p1. l  labels Γ p'"
       and IH2: " simple_labels Γ; wellformed Γ;
                   pn. p2  subterms (Γ pn); l  labels Γ p2 
                  p'sterms Γ p2. l  labels Γ p'"
       and ein: "pn. p1  p2  subterms (Γ pn)"
       and l12: "l  labels Γ (p1  p2)"
    from sl ein l12 have "labels Γ (p1  p2) = {l}"
      unfolding simple_labels_def by (metis empty_iff insert_iff)
    with wf have "labels Γ p1  labels Γ p2 = {l}" by simp
    moreover have "labels Γ p1  {}" and "labels Γ p2  {}"
      using wf by (metis labels_not_empty)+
    ultimately have "l  labels Γ p1" and "l  labels Γ p2"
      by (metis Un_iff empty_iff insert_iff set_eqI)+
    moreover from ein have "pn. p1  subterms (Γ pn)"
                       and "pn. p2  subterms (Γ pn)"
       by auto
    ultimately show "p'sterms Γ (p1  p2). llabels Γ p'"
      using wf IH1 [OF sl wf] IH2 [OF sl wf] by auto
  qed auto

lemma labels_in_sterms:
    fixes Γ l p
  assumes "wellformed Γ"
      and "llabels Γ p"
    shows "p'sterms Γ p. llabels Γ p'"
  using assms
  by (induct p rule: labels_pinduct [OF ‹wellformed Γ]) (auto intro: Un_iff)

lemma labels_sterms_labels:
    fixes Γ p p' l
  assumes "wellformed Γ"
      and "p'  sterms Γ p"
      and "l  labels Γ p'"
    shows "l  labels Γ p"
  using assms
  by (induct p rule: labels_pinduct [OF ‹wellformed Γ]) auto

primrec labelfrom :: "int  int  ('s, 'm, 'p, 'a) seqp  int × ('s, 'm, 'p, int) seqp"
where
   "labelfrom n nn ({_}f p)  =
      (let (nn', p') = labelfrom nn (nn + 1) p in
       (nn', {n}f p'))"
 | "labelfrom n nn ({_}f p) =
      (let (nn', p') = labelfrom nn (nn + 1) p in
       (nn', {n}f p'))"
 | "labelfrom n nn (p  q) =
      (let (nn', p') = labelfrom n nn p in
       let (nn'', q') = labelfrom n nn' q in
       (nn'', p'  q'))"
 | "labelfrom n nn ({_}unicast(fip, fmsg). p  q) =
      (let (nn', p')  = labelfrom nn (nn + 1) p in
       let (nn'', q') = labelfrom nn' (nn' + 1) q in
       (nn'', {n}unicast(fip, fmsg). p'  q'))"
 | "labelfrom n nn ({_}broadcast(fmsg). p) =
      (let (nn', p') = labelfrom nn (nn + 1) p in
       (nn', {n}broadcast(fmsg). p'))"
 | "labelfrom n nn ({_}groupcast(fipset, fmsg). p) =
      (let (nn', p') = labelfrom nn (nn + 1) p in
       (nn', {n}groupcast(fipset, fmsg). p'))"
 | "labelfrom n nn ({_}send(fmsg). p) =
      (let (nn', p') = labelfrom nn (nn + 1) p in
       (nn', {n}send(fmsg). p'))"
 | "labelfrom n nn ({_}deliver(fdata). p) =
      (let (nn', p') = labelfrom nn (nn + 1) p in
       (nn', {n}deliver(fdata). p'))"
 | "labelfrom n nn ({_}receive(fmsg). p) =
      (let (nn', p') = labelfrom nn (nn + 1) p in
       (nn', {n}receive(fmsg). p'))"
 | "labelfrom n nn (call(fargs)) = (nn - 1, call(fargs))"

datatype 'pn label =
    LABEL 'pn int  ("_-:_" [1000, 1000] 999)

instantiation "label" :: (ord) ord
begin

fun less_eq_label :: "'a label  'a label  bool"
where "(l1-:n1)  (l2-:n2) = (l1 = l2  n1  n2)"

definition less_label: "(l1::'a label) < l2  l1  l2  ¬ (l1  l2)"

instance ..
end

abbreviation labelled :: "'p  ('s, 'm, 'p, 'a) seqp  ('s, 'm, 'p, 'p label) seqp"
where "labelled pn p  labelmap (λl. LABEL pn l) (snd (labelfrom 0 1 p))"

end

Theory Inv_Cterms

(*  Title:       Inv_Cterms.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "A custom tactic for showing invariants via control terms"

theory Inv_Cterms
imports AWN_Labels
begin

text ‹
  This tactic tries to solve a goal by reducing it to a problem over (local) cterms (using
  one of the cterms\_intros intro rules); expanding those to consider all process names (using
  one of the ctermsl\_cases destruction rules); simplifying each (using the
  cterms\_env simplification rules); splitting them up into separate subgoals; replacing the
  derivative term with a variable; `executing' a transition of each term; and then simplifying.

  The tactic can stop after applying introduction rule (``inv\_cterms (intro\_only)''), or after
  having generated the verification condition subgoals and before having simplified them
  (``inv\_cterms (vcs\_only)''). It takes arguments to add or remove simplification rules
  (``simp add: lemmanames''), to add forward rules on assumptions (to introduce previously
  proved invariants; ``inv add: lemmanames''), or to add elimination rules that solve any
  remaining subgoals (``solve: lemmanames'').

  To configure the tactic for a set of transition rules:
  \begin{enumerate}
  \item add elimination rules: declare seqpTEs [cterms\_seqte]
  \item add rules to replace derivative terms: declare elimders [cterms\_elimders]
  \end{enumerate}

  To configure the tactic for a process environment (Γ›):
  \begin{enumerate}
  \item add simp rules: declare Γ›.simps [cterms\_env]
  \item add case rules: declare aodv\_proc\_cases [ctermsl\_cases]
  \item add invariant intros
      declare
        seq\_invariant\_ctermsI [OF aodv\_wf aodv\_control\_within aodv\_simple\_labels, cterms\_intros]
        seq\_step\_invariant\_ctermsI [OF aodv\_wf aodv\_control\_within aodv\_simple\_labels, cterms\_intros]
  \end{enumerate}

›

lemma has_ctermsl: "p  ctermsl Γ  p  ctermsl Γ" .

named_theorems cterms_elimders "rules for truncating sequential process terms"
named_theorems cterms_seqte "elimination rules for sequential process terms"
named_theorems cterms_env "simplification rules for sequential process environments"
named_theorems ctermsl_cases "destruction rules for case splitting ctermsl"
named_theorems cterms_intros "introduction rules from cterms"
named_theorems cterms_invs "invariants to try to apply at each vc"
named_theorems cterms_final "elimination rules to try on each vc after simplification"

ML fun simp_only thms ctxt =
  asm_full_simp_tac
     (ctxt |> Raw_Simplifier.clear_simpset |> fold Simplifier.add_simp thms)

(* shallow_simp is useful for mopping up assumptions before really trying to simplify.
   Perhaps surprisingly, this saves minutes in some of the proofs that use a lot of
   invariants of the form (l = P-:n --> P). *)
fun shallow_simp ctxt =
  let val ctxt' = Config.put simp_depth_limit 2 ctxt in
    TRY o safe_asm_full_simp_tac ctxt'
  end

fun create_vcs ctxt i =
  let val main_simp_thms = rev (Named_Theorems.get ctxt @{named_theorems cterms_env})
      val ctermsl_cases = rev (Named_Theorems.get ctxt @{named_theorems ctermsl_cases})
  in
    dresolve_tac ctxt @{thms has_ctermsl} i
    THEN_ELSE (dmatch_tac ctxt ctermsl_cases i
               THEN
               TRY (REPEAT_ALL_NEW (ematch_tac ctxt [@{thm disjE}]) i)
               THEN
               PARALLEL_ALLGOALS
                 (fn i => simp_only main_simp_thms ctxt i
                  THEN TRY (REPEAT_ALL_NEW (ematch_tac ctxt [@{thm disjE}]) i)), all_tac)
  end

fun try_invs ctxt =
  let val inv_thms = rev (Named_Theorems.get ctxt @{named_theorems cterms_invs})
      fun fapp thm =
        TRY o (EVERY' (forward_tac ctxt [thm] :: replicate (Thm.nprems_of thm - 1) (assume_tac ctxt)))
  in
    EVERY' (map fapp inv_thms)
  end

fun try_final ctxt =
  let val final_thms = rev (Named_Theorems.get ctxt @{named_theorems cterms_final})
      fun eapp thm = EVERY' (eresolve_tac ctxt [thm] :: replicate (Thm.nprems_of thm - 1) (assume_tac ctxt))
  in
    TRY o (FIRST' (map eapp final_thms))
  end

fun each ctxt =
  (EVERY' ((ematch_tac ctxt (rev (Named_Theorems.get ctxt @{named_theorems cterms_elimders})) ::
    replicate 2 (assume_tac ctxt)))
   THEN' simp_only @{thms labels_psimps} ctxt
   THEN' (ematch_tac ctxt (rev (Named_Theorems.get ctxt @{named_theorems cterms_seqte}))
     THEN_ALL_NEW
       (fn j => simp_only [@{thm mem_Collect_eq}] ctxt j
                  THEN REPEAT (eresolve_tac ctxt @{thms exE} j)
                  THEN REPEAT (eresolve_tac ctxt @{thms conjE} j))))
  ORELSE' (SOLVED' (clarsimp_tac ctxt))

fun simp_all ctxt =
  let val ctxt' =
        ctxt |> fold Splitter.add_split [@{thm if_split_asm}]
  in
    PARALLEL_ALLGOALS (shallow_simp ctxt)
    THEN
    TRY (CHANGED_PROP (PARALLEL_ALLGOALS (asm_full_simp_tac ctxt' THEN' try_final ctxt)))
  end

fun intro_and_invs ctxt i =
  let val cterms_intros = rev (Named_Theorems.get ctxt @{named_theorems cterms_intros}) in
    match_tac ctxt cterms_intros i
    THEN PARALLEL_ALLGOALS (try_invs ctxt)
  end

fun process_vcs ctxt _ =
  ALLGOALS (create_vcs ctxt ORELSE' (SOLVED' (clarsimp_tac ctxt)))
  THEN PARALLEL_ALLGOALS (TRY o each ctxt)

method_setup inv_cterms = let
    val intro_onlyN = "intro_only"
    val vcs_onlyN = "vcs_only"
    val invN = "inv"
    val solveN = "solve"

    val inv_cterms_options =
      (Args.parens (Args.$$$ intro_onlyN) >>  K intro_and_invs ||
       Args.parens (Args.$$$ vcs_onlyN) >>  K (fn ctxt => intro_and_invs ctxt
                                                          THEN' process_vcs ctxt) ||
       Scan.succeed (fn ctxt => intro_and_invs ctxt
                                THEN' process_vcs ctxt
                                THEN' K (simp_all ctxt)))
  in
    (Scan.lift inv_cterms_options --| Method.sections
      ((Args.$$$ invN -- Args.add -- Args.colon >>
        K (Method.modifier (Named_Theorems.add @{named_theorems cterms_invs}) ))
       :: (Args.$$$ solveN -- Args.colon >>
        K (Method.modifier (Named_Theorems.add @{named_theorems cterms_final}) ))
       :: Simplifier.simp_modifiers)
      >> (fn tac => SIMPLE_METHOD' o tac))
  end "solve invariants by considering all (interesting) control terms"

declare
  insert_iff [cterms_env]                                                
  Un_insert_right [cterms_env]
  sup_bot_right [cterms_env]
  Product_Type.prod_cases [cterms_env]
  ctermsl.simps [cterms_env]

end

Theory AWN_SOS_Labels

(*  Title:       AWN_SOS_Labels.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Configure the inv-cterms tactic for sequential processes"

theory AWN_SOS_Labels
imports AWN_SOS Inv_Cterms
begin

lemma elimder_guard:
  assumes "p = {l}fg qq"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' where "p = {l}fg p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma elimder_assign:
  assumes "p = {l}fa qq"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' where "p = {l}fa p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma elimder_ucast:
  assumes "p = {l}unicast(fip, fmsg).q1  q2"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' pp' where "p = {l}unicast(fip, fmsg).p'  pp'"
                   and "case a of unicast _ _  l'  labels Γ q1
                                        | _  l'  labels Γ q2"
  using assms by simp (erule seqpTEs, auto)

lemma elimder_bcast:
  assumes "p = {l}broadcast(fmsg).qq"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' where "p = {l}broadcast(fmsg). p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma elimder_gcast:
  assumes "p = {l}groupcast(fips, fmsg).qq"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' where "p = {l}groupcast(fips, fmsg). p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma elimder_send:
  assumes "p = {l}send(fmsg).qq"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' where "p = {l}send(fmsg). p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma elimder_deliver:
  assumes "p = {l}deliver(fdata).qq"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' where "p = {l}deliver(fdata).p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma elimder_receive:
  assumes "p = {l}receive(fmsg).qq"
      and "l'  labels Γ q"
      and "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  obtains p' where "p = {l}receive(fmsg).p'"
               and "l'  labels Γ qq"
  using assms by auto

lemmas elimders = 
   elimder_guard
   elimder_assign
   elimder_ucast
   elimder_bcast
   elimder_gcast
   elimder_send
   elimder_deliver
   elimder_receive

declare
  seqpTEs [cterms_seqte]
  elimders [cterms_elimders]

end

Theory Pnet

(*  Title:       Pnet.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lemmas for partial networks"

theory Pnet
imports AWN_SOS Invariants
begin

text ‹
  These lemmas mostly concern the preservation of node structure by @{term pnet_sos} transitions.
›

lemma pnet_maintains_dom:
  assumes "(s, a, s')  trans (pnet np p)"
    shows "net_ips s = net_ips s'"
  using assms proof (induction p arbitrary: s a s')
    fix i R σ s a s'
    assume "(s, a, s')  trans (pnet np i; R)"
    hence "(s, a, s')  node_sos (trans (np i))" ..
    thus "net_ips s = net_ips s'"
      by (rule node_sos.cases) simp_all
  next
    fix p1 p2 s a s'
    assume "s a s'. (s, a, s')  trans (pnet np p1)  net_ips s = net_ips s'"
       and "s a s'. (s, a, s')  trans (pnet np p2)  net_ips s = net_ips s'"
       and "(s, a, s')  trans (pnet np (p1  p2))"
    thus "net_ips s = net_ips s'"
      by simp (erule pnet_sos.cases, simp_all)
  qed

lemma pnet_net_ips_net_tree_ips [elim]:
  assumes "s  reachable (pnet np p) I"
    shows "net_ips s = net_tree_ips p"
  using assms proof induction
    fix s
    assume "s  init (pnet np p)"
    thus "net_ips s = net_tree_ips p"
    proof (induction p arbitrary: s)
      fix i R s
      assume "s  init (pnet np i; R)"
      then obtain ns where "s = NodeS i ns R" ..
      thus "net_ips s = net_tree_ips i; R"
        by simp
    next
      fix p1 p2 s
      assume IH1: "s. s  init (pnet np p1)  net_ips s = net_tree_ips p1"
         and IH2: "s. s  init (pnet np p2)  net_ips s = net_tree_ips p2"
         and "s  init (pnet np (p1  p2))"
      from this(3) obtain s1 s2 where "s1  init (pnet np p1)"
                                  and "s2  init (pnet np p2)"
                                  and "s = SubnetS s1 s2" by auto
      from this(1-2) have "net_ips s1 = net_tree_ips p1"
                      and "net_ips s2 = net_tree_ips p2"
        using IH1 IH2 by auto
      with s = SubnetS s1 s2 show "net_ips s = net_tree_ips (p1  p2)" by auto
    qed
  next
    fix s a s'
    assume "(s, a, s')  trans (pnet np p)"
       and "net_ips s = net_tree_ips p"
    from this(1) have "net_ips s = net_ips s'"
      by (rule pnet_maintains_dom)
    with ‹net_ips s = net_tree_ips p show "net_ips s' = net_tree_ips p"
      by simp
  qed

lemma pnet_init_net_ips_net_tree_ips:
  assumes "s  init (pnet np p)"
    shows "net_ips s = net_tree_ips p"
  using assms(1) by (rule reachable_init [THEN pnet_net_ips_net_tree_ips])

lemma pnet_init_in_net_ips_in_net_tree_ips [elim]:
  assumes "s  init (pnet np p)"
      and "i  net_ips s"
    shows "i  net_tree_ips p"
  using assms by (clarsimp dest!: pnet_init_net_ips_net_tree_ips)

lemma pnet_init_in_net_tree_ips_in_net_ips [elim]:
  assumes "s  init (pnet np p)"
      and "i  net_tree_ips p"
    shows "i  net_ips s"
  using assms by (clarsimp dest!: pnet_init_net_ips_net_tree_ips)

lemma pnet_init_not_in_net_tree_ips_not_in_net_ips [elim]:
  assumes "s  init (pnet np p)"
      and "i  net_tree_ips p"
    shows "i  net_ips s"
  proof
    assume "i  net_ips s"
    with assms(1) have "i  net_tree_ips p" ..
    with assms(2) show False ..
  qed

lemma net_node_reachable_is_node:
  assumes "st  reachable (pnet np ii; Ri) I"
    shows "ns R. st = NodeS ii ns R"
  using assms proof induct
    fix s
    assume "s  init (pnet np ii; Ri)"
    thus "ns R. s = NodeS ii ns R"
      by (rule pnet_node_init') simp
  next
    fix s a s'
    assume "s  reachable (pnet np ii; Ri) I"
       and "ns R. s = NodeS ii ns R"
       and "(s, a, s')  trans (pnet np ii; Ri)"
       and "I a"
    thus "ns R. s' = NodeS ii ns R"
      by (auto simp add: trans_node_comp dest!: node_sos_dest)
  qed

lemma partial_net_preserves_subnets:
  assumes "(SubnetS s t, a, st')  pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
    shows "s' t'. st' = SubnetS s' t'"
  using assms by cases simp_all

lemma net_par_reachable_is_subnet:
  assumes "st  reachable (pnet np (p1  p2)) I"
    shows "s t. st = SubnetS s t"
  using assms by induct (auto dest!: partial_net_preserves_subnets)

lemma reachable_par_subnet_induct [consumes, case_names init step]:
  assumes "SubnetS s t  reachable (pnet np (p1  p2)) I"
      and init: "s t. SubnetS s t  init (pnet np (p1  p2))  P s t"
      and step: "s t s' t' a. 
                    SubnetS s t  reachable (pnet np (p1  p2)) I;
                    P s t; (SubnetS s t, a, SubnetS s' t')  (trans (pnet np (p1  p2))); I a 
                     P s' t'"
    shows "P s t"
  using assms(1) proof (induction "SubnetS s t" arbitrary: s t)
    fix s t
    assume "SubnetS s t  init (pnet np (p1  p2))"
    with init show "P s t" .
  next
    fix st a s' t'
    assume "st  reachable (pnet np (p1  p2)) I"
       and tr: "(st, a, SubnetS s' t')  trans (pnet np (p1  p2))"
       and "I a"
       and IH: "s t. st = SubnetS s t  P s t"
    from this(1) obtain s t where "st = SubnetS s t"
                              and str: "SubnetS s t  reachable (pnet np (p1  p2)) I"
      by (metis net_par_reachable_is_subnet)
    note this(2)
    moreover from IH and st = SubnetS s t have "P s t" .
    moreover from st = SubnetS s t and tr
      have "(SubnetS s t, a, SubnetS s' t')  trans (pnet np (p1  p2))" by simp
    ultimately show "P s' t'"
      using I a by (rule step)
  qed

lemma subnet_reachable:
  assumes "SubnetS s1 s2  reachable (pnet np (p1  p2)) TT"
    shows "s1  reachable (pnet np p1) TT"
          "s2  reachable (pnet np p2) TT"
  proof -
    from assms have "s1  reachable (pnet np p1) TT
                   s2  reachable (pnet np p2) TT"
    proof (induction rule: reachable_par_subnet_induct)
      fix s1 s2
      assume "SubnetS s1 s2  init (pnet np (p1  p2))"
      thus "s1  reachable (pnet np p1) TT
           s2  reachable (pnet np p2) TT"
        by (auto dest: reachable_init)
    next
      case (step s1 s2 s1' s2' a)
      hence "SubnetS s1 s2  reachable (pnet np (p1  p2)) TT"
        and sr1: "s1  reachable (pnet np p1) TT"
        and sr2: "s2  reachable (pnet np p2) TT"
        and "(SubnetS s1 s2, a, SubnetS s1' s2')  trans (pnet np (p1  p2))" by auto
      from this(4)
        have "(SubnetS s1 s2, a, SubnetS s1' s2')  pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
          by simp
      thus "s1'  reachable (pnet np p1) TT
          s2'  reachable (pnet np p2) TT"
        by cases (insert sr1 sr2, auto elim: reachable_step)
    qed
    thus "s1  reachable (pnet np p1) TT"
         "s2  reachable (pnet np p2) TT" by auto
  qed

lemma delivered_to_node [elim]:
  assumes "s  reachable (pnet np ii; Ri) TT"
      and "(s, i:deliver(d), s')  trans (pnet np ii; Ri)"
    shows "i = ii"
  proof -
    from assms(1) obtain P R where "s = NodeS ii P R"
      by (metis net_node_reachable_is_node)
    with assms(2) show "i = ii"
       by (clarsimp simp add: trans_node_comp elim!: node_deliverTE')
  qed

lemma delivered_to_net_ips:
  assumes "s  reachable (pnet np p) TT"
      and "(s, i:deliver(d), s')  trans (pnet np p)"
    shows "i  net_ips s"
  using assms proof (induction p arbitrary: s s')
    fix ii Ri s s'
    assume sr: "s  reachable (pnet np ii; Ri) TT"
       and "(s, i:deliver(d), s')  trans (pnet np ii; Ri)"
    from this(2) have tr: "(s, i:deliver(d), s')  node_sos (trans (np ii))" by simp
    from sr obtain P R where [simp]: "s = NodeS ii P R"
      by (metis net_node_reachable_is_node)
    moreover from tr obtain P' R' where [simp]: "s' = NodeS ii P' R'"
      by simp (metis node_sos_dest)
    ultimately have "i = ii" using tr by auto
    thus "i  net_ips s" by simp
  next
    fix p1 p2 s s'
    assume IH1: "s s'.  s  reachable (pnet np p1) TT;
                          (s, i:deliver(d), s')  trans (pnet np p1)   i  net_ips s"
       and IH2: "s s'.  s  reachable (pnet np p2) TT;
                          (s, i:deliver(d), s')  trans (pnet np p2)   i  net_ips s"
       and sr: "s  reachable (pnet np (p1  p2)) TT"
       and tr: "(s, i:deliver(d), s')  trans (pnet np (p1  p2))"
    from tr have "(s, i:deliver(d), s')  pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
      by simp
    thus "i  net_ips s"
    proof (rule partial_deliverTE)
      fix s1 s1' s2
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1' s2"
         and tr: "(s1, i:deliver(d), s1')  trans (pnet np p1)"
      from sr have "s1  reachable (pnet np p1) TT"
        by (auto simp only: s = SubnetS s1 s2 elim: subnet_reachable)
      hence "i  net_ips s1" using tr by (rule IH1)
      thus "i  net_ips s" by (simp add: s = SubnetS s1 s2)
    next
      fix s2 s2' s1
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1 s2'"
         and tr: "(s2, i:deliver(d), s2')  trans (pnet np p2)"
      from sr have "s2  reachable (pnet np p2) TT"
        by (auto simp only: s = SubnetS s1 s2 elim: subnet_reachable)
      hence "i  net_ips s2" using tr by (rule IH2)
      thus "i  net_ips s" by (simp add: s = SubnetS s1 s2)
    qed
  qed

lemma wf_net_tree_net_ips_disjoint [elim]:
  assumes "wf_net_tree (p1  p2)"
      and "s1  reachable (pnet np p1) S"
      and "s2  reachable (pnet np p2) S"
    shows "net_ips s1  net_ips s2 = {}"
  proof -
    from ‹wf_net_tree (p1  p2) have "net_tree_ips p1  net_tree_ips p2 = {}" by auto
    moreover from assms(2) have "net_ips s1 = net_tree_ips p1" ..
    moreover from assms(3) have "net_ips s2 = net_tree_ips p2" ..
    ultimately show ?thesis by simp
  qed

lemma init_mapstate_Some_aodv_init [elim]:
  assumes "s  init (pnet np p)"
      and "netmap s i = Some v"
    shows "v  init (np i)"
  using assms proof (induction p arbitrary: s)
    fix ii R s
    assume "s  init (pnet np ii; R)"
       and "netmap s i = Some v"
    from this(1) obtain ns where s: "s = NodeS ii ns R"
      and ns: "ns  init (np ii)" ..
    from s and ‹netmap s i = Some v have "i = ii"
      by simp (metis domI domIff)
    with s ns show "v  init (np i)"
      using ‹netmap s i = Some v by simp
  next
    fix p1 p2 s
    assume IH1: "s. s  init (pnet np p1)  netmap s i = Some v  v  init (np i)"
       and IH2: "s. s  init (pnet np p2)  netmap s i = Some v  v  init (np i)"
       and "s  init (pnet np (p1  p2))"
       and "netmap s i = Some v"
    from this(3) obtain s1 s2 where "s = SubnetS s1 s2"
                                and "s1  init (pnet np p1)"
                                and "s2  init (pnet np p2)" by auto
    from this(1) and ‹netmap s i = Some v
      have "netmap s1 i = Some v  netmap s2 i = Some v" by auto
    thus "v  init (np i)"
    proof
      assume "netmap s1 i = Some v"
      with s1  init (pnet np p1) show ?thesis by (rule IH1)
    next
      assume "netmap s2 i = Some v"
      with s2  init (pnet np p2) show ?thesis by (rule IH2)
    qed
  qed

lemma reachable_connect_netmap [elim]:
  assumes "s  reachable (pnet np n) TT"
      and "(s, connect(i, i'), s')  trans (pnet np n)"
    shows "netmap s' = netmap s"
  using assms proof (induction n arbitrary: s s')
    fix ii Ri s s'
    assume sr: "s  reachable (pnet np ii; Ri) TT"
       and "(s, connect(i, i'), s')  trans (pnet np ii; Ri)"
    from this(2) have tr: "(s, connect(i, i'), s')  node_sos (trans (np ii))" ..
    from sr obtain p R where "s = NodeS ii p R"
      by (metis net_node_reachable_is_node)
    with tr show "netmap s' = netmap s"
      by (auto elim!: node_sos.cases)
  next
    fix p1 p2 s s'
    assume IH1: "s s'.  s  reachable (pnet np p1) TT;
                          (s, connect(i, i'), s')  trans (pnet np p1)   netmap s' = netmap s"
       and IH2: "s s'.  s  reachable (pnet np p2) TT;
                          (s, connect(i, i'), s')  trans (pnet np p2)   netmap s' = netmap s"
       and sr: "s  reachable (pnet np (p1  p2)) TT"
       and tr: "(s, connect(i, i'), s')  trans (pnet np (p1  p2))"
    from tr have "(s, connect(i, i'), s')  pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
      by simp
    thus "netmap s' = netmap s"
    proof cases
      fix s1 s1' s2 s2'
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1' s2'"
         and tr1: "(s1, connect(i, i'), s1')  trans (pnet np p1)"
         and tr2: "(s2, connect(i, i'), s2')  trans (pnet np p2)"
    from this(1) and sr
      have "SubnetS s1 s2  reachable (pnet np (p1  p2)) TT" by simp
    hence sr1: "s1  reachable (pnet np p1) TT"
      and sr2: "s2  reachable (pnet np p2) TT"
      by (auto intro: subnet_reachable)
    from sr1 tr1 have "netmap s1' = netmap s1" by (rule IH1)
    moreover from sr2 tr2 have "netmap s2' = netmap s2" by (rule IH2)
    ultimately show "netmap s' = netmap s"
      using s = SubnetS s1 s2 and s' = SubnetS s1' s2' by simp
    qed simp_all
  qed

lemma reachable_disconnect_netmap [elim]:
  assumes "s  reachable (pnet np n) TT"
      and "(s, disconnect(i, i'), s')  trans (pnet np n)"
    shows "netmap s' = netmap s"
  using assms proof (induction n arbitrary: s s')
    fix ii Ri s s'
    assume sr: "s  reachable (pnet np ii; Ri) TT"
       and "(s, disconnect(i, i'), s')  trans (pnet np ii; Ri)"
    from this(2) have tr: "(s, disconnect(i, i'), s')  node_sos (trans (np ii))" ..
    from sr obtain p R where "s = NodeS ii p R"
      by (metis net_node_reachable_is_node)
    with tr show "netmap s' = netmap s"
      by (auto elim!: node_sos.cases)
  next
    fix p1 p2 s s'
    assume IH1: "s s'.  s  reachable (pnet np p1) TT;
                          (s, disconnect(i, i'), s')  trans (pnet np p1)   netmap s' = netmap s"
       and IH2: "s s'.  s  reachable (pnet np p2) TT;
                          (s, disconnect(i, i'), s')  trans (pnet np p2)   netmap s' = netmap s"
       and sr: "s  reachable (pnet np (p1  p2)) TT"
       and tr: "(s, disconnect(i, i'), s')  trans (pnet np (p1  p2))"
    from tr have "(s, disconnect(i, i'), s')  pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
      by simp
    thus "netmap s' = netmap s"
    proof cases
      fix s1 s1' s2 s2'
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1' s2'"
         and tr1: "(s1, disconnect(i, i'), s1')  trans (pnet np p1)"
         and tr2: "(s2, disconnect(i, i'), s2')  trans (pnet np p2)"
    from this(1) and sr
      have "SubnetS s1 s2  reachable (pnet np (p1  p2)) TT" by simp
    hence sr1: "s1  reachable (pnet np p1) TT"
      and sr2: "s2  reachable (pnet np p2) TT"
      by (auto intro: subnet_reachable)
    from sr1 tr1 have "netmap s1' = netmap s1" by (rule IH1)
    moreover from sr2 tr2 have "netmap s2' = netmap s2" by (rule IH2)
    ultimately show "netmap s' = netmap s"
      using s = SubnetS s1 s2 and s' = SubnetS s1' s2' by simp
    qed simp_all
  qed

fun net_ip_action :: "(ip  ('s, 'm seq_action) automaton)
                        'm node_action  ip  net_tree  's net_state  's net_state  bool"
where
    "net_ip_action np a i (p1  p2) (SubnetS s1 s2) (SubnetS s1' s2') =
         ((i  net_ips s1  ((s1, a, s1')  trans (pnet np p1)
                                 s2' = s2  net_ip_action np a i p1 s1 s1'))
           (i  net_ips s2  ((s2, a, s2')  trans (pnet np p2))
                                    s1' = s1  net_ip_action np a i p2 s2 s2'))"
  | "net_ip_action np a i p s s' = True"

lemma pnet_tau_single_node [elim]:
  assumes "wf_net_tree p"
      and "s  reachable (pnet np p) TT"
      and "(s, τ, s')  trans (pnet np p)"
  shows "inet_ips s. ((j. ji  netmap s' j = netmap s j)
                          net_ip_action np τ i p s s')"
  using assms proof (induction p arbitrary: s s')
    fix ii Ri s s'
    assume "s  reachable (pnet np ii; Ri) TT"
       and "(s, τ, s')  trans (pnet np ii; Ri)"
    from this obtain p R p' R' where "s = NodeS ii p R" and "s' = NodeS ii p' R'"
      by (metis (hide_lams, no_types) TT_True net_node_reachable_is_node
                                      reachable_step)
    hence "net_ips s = {ii}"
      and "net_ips s' = {ii}" by simp_all
    hence "idom (netmap s). j. j  i  netmap s' j = netmap s j"
      by (simp add: net_ips_is_dom_netmap)
    thus "inet_ips s. (j. j  i  netmap s' j = netmap s j)
                          net_ip_action np τ i (ii; Ri) s s'"
      by (simp add: net_ips_is_dom_netmap)
  next
    fix p1 p2 s s'
    assume IH1: "s s'.  wf_net_tree p1;
                          s  reachable (pnet np p1) TT;
                          (s, τ, s')  trans (pnet np p1) 
                          inet_ips s. (j. j  i  netmap s' j = netmap s j)
                                             net_ip_action np τ i p1 s s'"
       and IH2: "s s'.  wf_net_tree p2;
                          s  reachable (pnet np p2) TT;
                          (s, τ, s')  trans (pnet np p2) 
                          inet_ips s. (j. j  i  netmap s' j = netmap s j)
                                             net_ip_action np τ i p2 s s'"
       and sr: "s  reachable (pnet np (p1  p2)) TT"
       and "wf_net_tree (p1  p2)"
       and tr: "(s, τ, s')  trans (pnet np (p1  p2))"
    from ‹wf_net_tree (p1  p2) have "net_tree_ips p1  net_tree_ips p2 = {}"
                                  and "wf_net_tree p1" 
                                  and "wf_net_tree p2" by auto
    from tr have "(s, τ, s')  pnet_sos (trans (pnet np p1)) (trans (pnet np p2))" by simp
    thus "inet_ips s. (j. j  i  netmap s' j = netmap s j)
                         net_ip_action np τ i (p1  p2) s s'"
    proof cases
      fix s1 s1' s2
      assume subs:  "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1' s2"
         and tr1: "(s1, τ, s1')  trans (pnet np p1)"
      from sr have sr1: "s1  reachable (pnet np p1) TT"
               and "s2  reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with ‹net_tree_ips p1  net_tree_ips p2 = {} have "dom(netmap s1)  dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      from ‹wf_net_tree p1 sr1 tr1 obtain i where "idom(netmap s1)"
                                               and *: "j. j  i  netmap s1' j = netmap s1 j"
                                               and "net_ip_action np τ i p1 s1 s1'"
          by (auto simp add: net_ips_is_dom_netmap dest!: IH1)
      from this(1) and ‹dom(netmap s1)  dom(netmap s2) = {} have "idom(netmap s2)"
        by auto
      with subs subs' tr1 ‹net_ip_action np τ i p1 s1 s1' have "net_ip_action np τ i (p1  p2) s s'"
        by (simp add: net_ips_is_dom_netmap)
      moreover have "j. j  i  (netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j  i"
        with * have "netmap s1' j = netmap s1 j" by simp
        thus "(netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) map_add_dom_app_simps(1) map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using idom(netmap s1) subs subs'
        by (auto simp add: net_ips_is_dom_netmap)
    next
      fix s2 s2' s1
      assume subs: "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1 s2'"
         and tr2: "(s2, τ, s2')  trans (pnet np p2)"
      from sr have "s1  reachable (pnet np p1) TT"
               and sr2: "s2  reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with ‹net_tree_ips p1  net_tree_ips p2 = {} have "dom(netmap s1)  dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      from ‹wf_net_tree p2 sr2 tr2 obtain i where "idom(netmap s2)"
                                               and *: "j. j  i  netmap s2' j = netmap s2 j"
                                               and "net_ip_action np τ i p2 s2 s2'"
          by (auto simp add: net_ips_is_dom_netmap dest!: IH2)
      from this(1) and ‹dom(netmap s1)  dom(netmap s2) = {} have "idom(netmap s1)"
        by auto
      with subs subs' tr2 ‹net_ip_action np τ i p2 s2 s2' have "net_ip_action np τ i (p1  p2) s s'"
        by (simp add: net_ips_is_dom_netmap)
      moreover have "j. j  i  (netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j  i"
        with * have "netmap s2' j = netmap s2 j" by simp
        thus "(netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) domD map_add_Some_iff map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using idom(netmap s2) subs subs'
        by (clarsimp simp add: net_ips_is_dom_netmap)
           (metis domI dom_map_add map_add_find_right)
    qed simp_all
  qed

lemma pnet_deliver_single_node [elim]:
  assumes "wf_net_tree p"
      and "s  reachable (pnet np p) TT"
      and "(s, i:deliver(d), s')  trans (pnet np p)"
  shows "(j. ji  netmap s' j = netmap s j)  net_ip_action np (i:deliver(d)) i p s s'"
    (is "?P p s s'")
  using assms proof (induction p arbitrary: s s')
    fix ii Ri s s'
    assume sr: "s  reachable (pnet np ii; Ri) TT"
       and tr: "(s, i:deliver(d), s')  trans (pnet np ii; Ri)"
    from this obtain p R p' R' where "s = NodeS ii p R" and "s' = NodeS ii p' R'"
      by (metis (hide_lams, no_types) TT_True net_node_reachable_is_node
                                      reachable_step)
    hence "net_ips s = {ii}"
      and "net_ips s' = {ii}" by simp_all
    hence "j. j  ii  netmap s' j = netmap s j"
      by simp
    moreover from sr tr have "i = ii" by (rule delivered_to_node)
    ultimately show "(j. j  i  netmap s' j = netmap s j)
                      net_ip_action np (i:deliver(d)) i (ii; Ri) s s'"
      by simp
  next
    fix p1 p2 s s'
    assume IH1: "s s'.  wf_net_tree p1;
                          s  reachable (pnet np p1) TT;
                          (s, i:deliver(d), s')  trans (pnet np p1) 
                          (j. j  i  netmap s' j = netmap s j)
                              net_ip_action np (i:deliver(d)) i p1 s s'"
       and IH2: "s s'.  wf_net_tree p2;
                          s  reachable (pnet np p2) TT;
                          (s, i:deliver(d), s')  trans (pnet np p2) 
                          (j. j  i  netmap s' j = netmap s j)
                              net_ip_action np (i:deliver(d)) i p2 s s'"
       and sr: "s  reachable (pnet np (p1  p2)) TT"
       and "wf_net_tree (p1  p2)"
       and tr: "(s, i:deliver(d), s')  trans (pnet np (p1  p2))"
    from ‹wf_net_tree (p1  p2) have "net_tree_ips p1  net_tree_ips p2 = {}"
                                  and "wf_net_tree p1" 
                                  and "wf_net_tree p2" by auto
    from tr have "(s, i:deliver(d), s')  pnet_sos (trans (pnet np p1)) (trans (pnet np p2))" by simp
    thus "(j. j  i  netmap s' j = netmap s j)
           net_ip_action np (i:deliver(d)) i (p1  p2) s s'"
    proof cases
      fix s1 s1' s2
      assume subs:  "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1' s2"
         and tr1: "(s1, i:deliver(d), s1')  trans (pnet np p1)"
      from sr have sr1: "s1  reachable (pnet np p1) TT"
               and "s2  reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with ‹net_tree_ips p1  net_tree_ips p2 = {} have "dom(netmap s1)  dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      moreover from sr1 tr1 have "i  net_ips s1" by (rule delivered_to_net_ips)
      ultimately have "idom(netmap s2)" by (auto simp add: net_ips_is_dom_netmap)

      from ‹wf_net_tree p1 sr1 tr1 have *: "j. j  i  netmap s1' j = netmap s1 j"
                                     and "net_ip_action np (i:deliver(d)) i p1 s1 s1'"
          by (auto dest!: IH1)
      from subs subs' tr1 this(2) idom(netmap s2)
        have "net_ip_action np (i:deliver(d)) i (p1  p2) s s'"
          by (simp add: net_ips_is_dom_netmap)
      moreover have "j. j  i  (netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j  i"
        with * have "netmap s1' j = netmap s1 j" by simp
        thus "(netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) map_add_dom_app_simps(1) map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using inet_ips s1 subs subs' by auto
    next
      fix s2 s2' s1
      assume subs: "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1 s2'"
         and tr2: "(s2, i:deliver(d), s2')  trans (pnet np p2)"
      from sr have "s1  reachable (pnet np p1) TT"
               and sr2: "s2  reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with ‹net_tree_ips p1  net_tree_ips p2 = {} have "dom(netmap s1)  dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      moreover from sr2 tr2 have "i  net_ips s2" by (rule delivered_to_net_ips)
      ultimately have "idom(netmap s1)" by (auto simp add: net_ips_is_dom_netmap)

      from ‹wf_net_tree p2 sr2 tr2 have *: "j. j  i  netmap s2' j = netmap s2 j"
                                     and "net_ip_action np (i:deliver(d)) i p2 s2 s2'"
          by (auto dest!: IH2)
      from subs subs' tr2 this(2) idom(netmap s1)
        have "net_ip_action np (i:deliver(d)) i (p1  p2) s s'"
          by (simp add: net_ips_is_dom_netmap)
      moreover have "j. j  i  (netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j  i"
        with * have "netmap s2' j = netmap s2 j" by simp
        thus "(netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) domD map_add_Some_iff map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using inet_ips s2 subs subs' by auto
    qed simp_all
  qed

end

Theory Closed

(*  Title:       Closed.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lemmas for closed networks"

theory Closed
imports Pnet
begin

lemma complete_net_preserves_subnets:
  assumes "(SubnetS s t, a, st')  cnet_sos (pnet_sos (trans (pnet np p1)) (trans (pnet np p2)))"
    shows "s' t'. st' = SubnetS s' t'"
  using assms by cases (auto dest: partial_net_preserves_subnets)

lemma complete_net_reachable_is_subnet:
  assumes "st  reachable (closed (pnet np (p1  p2))) I"
    shows "s t. st = SubnetS s t"
  using assms by induction (auto dest!: complete_net_preserves_subnets)

lemma closed_reachable_par_subnet_induct [consumes, case_names init step]:
  assumes "SubnetS s t  reachable (closed (pnet np (p1  p2))) I"
      and init: "s t. SubnetS s t  init (closed (pnet np (p1  p2)))  P s t"
      and step: "s t s' t' a. 
                    SubnetS s t  reachable (closed (pnet np (p1  p2))) I;
                    P s t; (SubnetS s t, a, SubnetS s' t')  trans (closed (pnet np (p1  p2))); I a 
                     P s' t'"
    shows "P s t"
  using assms(1) proof (induction "SubnetS s t" arbitrary: s t)
    fix s t
    assume "SubnetS s t  init (closed (pnet np (p1  p2)))"
    with init show "P s t" .
  next
    fix st a s' t'
    assume "st  reachable (closed (pnet np (p1  p2))) I"
       and tr: "(st, a, SubnetS s' t')  trans (closed (pnet np (p1  p2)))"
       and "I a"
       and IH: "s t. st = SubnetS s t  P s t"
    from this(1) obtain s t where "st = SubnetS s t"
                              and "SubnetS s t  reachable (closed (pnet np (p1  p2))) I"
      by (metis complete_net_reachable_is_subnet)
    note this(2)
    moreover from IH and st = SubnetS s t have "P s t" .
    moreover from tr and st = SubnetS s t
      have "(SubnetS s t, a, SubnetS s' t')  trans (closed (pnet np (p1  p2)))" by simp
    ultimately show "P s' t'"
      using I a by (rule assms(3))
  qed

lemma reachable_closed_reachable_pnet [elim]:
  assumes "s  reachable (closed (pnet np n)) TT"
    shows "s  reachable (pnet np n) TT"
  using assms proof (induction rule: reachable.induct)
    fix s s' a
    assume sr: "s  reachable (pnet np n) TT"
       and "(s, a, s')  trans (closed (pnet np n))"
    from this(2) have "(s, a, s')  cnet_sos (trans (pnet np n))" by simp
    thus "s'  reachable (pnet np n) TT"
      by cases (insert sr, auto elim!: reachable_step)
  qed (auto elim: reachable_init)

lemma closed_node_net_state [elim]:
  assumes "st  reachable (closed (pnet np ii; Ri)) TT"
  obtains ξ p q R where "st = NodeS ii ((ξ, p), q) R"
  using assms by (metis net_node_reachable_is_node reachable_closed_reachable_pnet surj_pair)

lemma closed_subnet_net_state [elim]:
  assumes "st  reachable (closed (pnet np (p1  p2))) TT"
  obtains s t where "st = SubnetS s t"
  using assms by (metis reachable_closed_reachable_pnet net_par_reachable_is_subnet)

lemma closed_imp_pnet_trans [elim, dest]:
  assumes "(s, a, s')  trans (closed (pnet np n))"
    shows "a'. (s, a', s')  trans (pnet np n)"
  using assms by (auto elim!: cnet_sos.cases)

lemma reachable_not_in_net_tree_ips [elim]:
  assumes "s  reachable (closed (pnet np n)) TT"
      and "inet_tree_ips n"
    shows "netmap s i = None"
  using assms proof induction
    fix s
    assume "s  init (closed (pnet np n))"
       and "i  net_tree_ips n"
    thus "netmap s i = None"                                     
    proof (induction n arbitrary: s)
      fix ii R s
      assume "s  init (closed (pnet np ii; R))"
         and "i  net_tree_ips ii; R"
      from this(2) have "i  ii" by simp
      moreover from s  init (closed (pnet np ii; R)) obtain p where "s = NodeS ii p R"
        by simp (metis pnet.simps(1) pnet_node_init')
      ultimately show "netmap s i = None" by simp
    next
      fix p1 p2 s
      assume IH1: "s. s  init (closed (pnet np p1))  i  net_tree_ips p1
                         netmap s i = None"
         and IH2: "s. s  init (closed (pnet np p2))  i  net_tree_ips p2
                         netmap s i = None"
         and "s  init (closed (pnet np (p1  p2)))"
         and "i  net_tree_ips (p1  p2)"
      from this(3) obtain s1 s2 where "s = SubnetS s1 s2"
                                  and "s1  init (closed (pnet np p1))"
                                  and "s2  init (closed (pnet np p2))" by simp metis
      moreover from i  net_tree_ips (p1  p2) have "i  net_tree_ips p1"
                                                  and "i  net_tree_ips p2" by auto
      ultimately have "netmap s1 i = None"
                  and "netmap s2 i = None"
        using IH1 IH2 by auto
      with s = SubnetS s1 s2 show "netmap s i = None" by simp
    qed
  next
    fix s a s'
    assume sr: "s  reachable (closed (pnet np n)) TT"
       and tr: "(s, a, s')  trans (closed (pnet np n))"
       and IH: "i  net_tree_ips n  netmap s i = None"
       and "i  net_tree_ips n"
    from this(3-4) have "inet_ips s" by auto
    with tr have "inet_ips s'"
      by simp (erule cnet_sos.cases, (metis net_ips_is_dom_netmap pnet_maintains_dom)+)
    thus "netmap s' i = None" by simp
  qed

lemma closed_pnet_aodv_init [elim]:
  assumes "s  init (closed (pnet np n))"
      and "inet_tree_ips n"
    shows "the (netmap s i)  init (np i)"
  using assms proof (induction n arbitrary: s)
    fix ii R s
    assume "s  init (closed (pnet np ii; R))"
       and "inet_tree_ips ii; R"
    hence "s  init (pnet np i; R)" by simp
    then obtain p where "s = NodeS i p R"
                    and "p  init (np i)" ..
    with s = NodeS i p R have "netmap s = [i  p]" by simp
    with p  init (np i) show "the (netmap s i)  init (np i)" by simp
  next
    fix p1 p2 s
    assume IH1: "s. s  init (closed (pnet np p1)) 
                      inet_tree_ips p1  the (netmap s i)  init (np i)"
       and IH2: "s. s  init (closed (pnet np p2)) 
                     inet_tree_ips p2  the (netmap s i)  init (np i)"
       and "s  init (closed (pnet np (p1  p2)))"
       and "inet_tree_ips (p1  p2)"
    from this(3) obtain s1 s2 where "s = SubnetS s1 s2"
                                and "s1  init (closed (pnet np p1))"
                                and "s2  init (closed (pnet np p2))"
      by auto
    from this(2) have "net_tree_ips p1 = net_ips s1"
      by (clarsimp dest!: pnet_init_net_ips_net_tree_ips)
    from s2  init (closed (pnet np p2)) have "net_tree_ips p2 = net_ips s2"
      by (clarsimp dest!: pnet_init_net_ips_net_tree_ips)
    show "the (netmap s i)  init (np i)"
    proof (cases "inet_tree_ips p2")
      assume "inet_tree_ips p2"
      with s2  init (closed (pnet np p2)) have "the (netmap s2 i)  init (np i)"
        by (rule IH2)
      moreover from inet_tree_ips p2 and ‹net_tree_ips p2 = net_ips s2
        have "inet_ips s2" by simp
      ultimately show ?thesis
        using s = SubnetS s1 s2 by (auto simp add: net_ips_is_dom_netmap)
    next
      assume "inet_tree_ips p2"
      with inet_tree_ips (p1  p2) have "inet_tree_ips p1" by simp
      with s1  init (closed (pnet np p1)) have "the (netmap s1 i)  init (np i)"
        by (rule IH1)
      moreover from inet_tree_ips p1 and ‹net_tree_ips p1 = net_ips s1
        have "inet_ips s1" by simp
      moreover from inet_tree_ips p2 and ‹net_tree_ips p2 = net_ips s2
        have "inet_ips s2" by simp
      ultimately show ?thesis
        using s = SubnetS s1 s2
        by (simp add: map_add_dom_app_simps net_ips_is_dom_netmap)
    qed
  qed

end

Theory OAWN_SOS

(*  Title:       OAWN_SOS.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Open semantics of the Algebra of Wireless Networks"

theory OAWN_SOS
imports TransitionSystems AWN
begin

text ‹
  These are variants of the SOS rules that work against a mixed global/local context, where
  the global context is represented by a function @{term σ} mapping ip addresses to states.
›

subsection "Open structural operational semantics for sequential process expressions "

inductive_set
  oseqp_sos
  :: "('s, 'm, 'p, 'l) seqp_env  ip
       ((ip  's) × ('s, 'm, 'p, 'l) seqp, 'm seq_action) transition set"
  for Γ :: "('s, 'm, 'p, 'l) seqp_env"
  and i :: ip
where
    obroadcastT: "σ' i = σ i 
                  ((σ, {l}broadcast(smsg).p),        broadcast (smsg (σ i)),              (σ', p))  oseqp_sos Γ i"
  | ogroupcastT: "σ' i = σ i 
                  ((σ, {l}groupcast(sips, smsg).p),  groupcast (sips (σ i)) (smsg (σ i)), (σ', p))  oseqp_sos Γ i"
  | ounicastT:   "σ' i = σ i 
                  ((σ, {l}unicast(sip, smsg).p  q), unicast (sip (σ i)) (smsg (σ i)),    (σ', p))  oseqp_sos Γ i"
  | onotunicastT:"σ' i = σ i 
                  ((σ, {l}unicast(sip, smsg).p  q), ¬unicast (sip (σ i)),               (σ', q))  oseqp_sos Γ i"
  | osendT:      "σ' i = σ i 
                  ((σ, {l}send(smsg).p),             send (smsg (σ i)),                  (σ', p))  oseqp_sos Γ i"
  | odeliverT:   "σ' i = σ i 
                  ((σ, {l}deliver(sdata).p),         deliver (sdata (σ i)),              (σ', p))  oseqp_sos Γ i"
  | oreceiveT:   "σ' i = umsg msg (σ i) 
                  ((σ, {l}receive(umsg).p),          receive msg,                       (σ', p))  oseqp_sos Γ i"
  | oassignT:    "σ' i = u (σ i) 
                  ((σ, {l}u p),                    τ,                                 (σ', p))  oseqp_sos Γ i"

  | ocallT:      "((σ, Γ pn), a, (σ', p'))  oseqp_sos Γ i 
                  ((σ, call(pn)), a, (σ', p'))  oseqp_sos Γ i" (* TPB: quite different to Table 1 *)

  | ochoiceT1:   "((σ, p), a, (σ', p'))  oseqp_sos Γ i 
                  ((σ, p  q), a, (σ', p'))  oseqp_sos Γ i"
  | ochoiceT2:   "((σ, q), a, (σ', q'))  oseqp_sos Γ i 
                  ((σ, p  q), a, (σ', q'))  oseqp_sos Γ i"

  | oguardT:     "σ' i  g (σ i)  ((σ, {l}g p), τ, (σ', p))  oseqp_sos Γ i"

inductive_cases
      oseq_callTE [elim]:      "((σ, call(pn)), a, (σ', q))  oseqp_sos Γ i"
  and oseq_choiceTE [elim]:    "((σ, p1  p2), a, (σ', q))  oseqp_sos Γ i"

lemma oseq_broadcastTE [elim]:
  "((σ, {l}broadcast(smsg). p), a, (σ', q))  oseqp_sos Γ i;
    a = broadcast (smsg (σ i)); σ' i = σ i; q = p  P  P"
  by (ind_cases "((σ, {l}broadcast(smsg). p), a, (σ', q))  oseqp_sos Γ i") simp

lemma oseq_groupcastTE [elim]:
  "((σ, {l}groupcast(sips, smsg). p), a, (σ', q))  oseqp_sos Γ i;
    a = groupcast (sips (σ i)) (smsg (σ i)); σ' i = σ i; q = p  P  P"
  by (ind_cases "((σ, {l}groupcast(sips, smsg). p), a, (σ', q))  oseqp_sos Γ i") simp

lemma oseq_unicastTE [elim]:
  "((σ, {l}unicast(sip, smsg). p  q), a, (σ', r))  oseqp_sos Γ i;
    a = unicast (sip (σ i)) (smsg (σ i)); σ' i = σ i; r = p  P;
    a = ¬unicast (sip (σ i)); σ' i = σ i; r = q  P  P"
  by (ind_cases "((σ, {l}unicast(sip, smsg). p  q), a, (σ', r))  oseqp_sos Γ i") simp_all

lemma oseq_sendTE [elim]:
  "((σ, {l}send(smsg). p), a, (σ', q))  oseqp_sos Γ i;
    a = send (smsg (σ i)); σ' i = σ i; q = p  P  P"
  by (ind_cases "((σ, {l}send(smsg). p), a, (σ', q))  oseqp_sos Γ i") simp

lemma oseq_deliverTE [elim]:
  "((σ, {l}deliver(sdata). p), a, (σ', q))  oseqp_sos Γ i;
    a = deliver (sdata (σ i)); σ' i = σ i; q = p  P  P"
  by (ind_cases "((σ, {l}deliver(sdata). p), a, (σ', q))  oseqp_sos Γ i") simp

lemma oseq_receiveTE [elim]:
  "((σ, {l}receive(umsg). p), a, (σ', q))  oseqp_sos Γ i;
    msg. a = receive msg; σ' i = umsg msg (σ i); q = p  P  P"
  by (ind_cases "((σ, {l}receive(umsg). p), a, (σ', q))  oseqp_sos Γ i") simp

lemma oseq_assignTE [elim]:
  "((σ, {l}u p), a, (σ', q))  oseqp_sos Γ i; a = τ; σ' i = u (σ i); q = p  P  P"
  by (ind_cases "((σ, {l}u p), a, (σ', q))  oseqp_sos Γ i") simp

lemma oseq_guardTE [elim]:
  "((σ, {l}g p), a, (σ', q))  oseqp_sos Γ i; a = τ; σ' i  g (σ i); q = p  P  P"
  by (ind_cases "((σ, {l}g p), a, (σ', q))  oseqp_sos Γ i") simp

lemmas oseqpTEs =
  oseq_broadcastTE
  oseq_groupcastTE
  oseq_unicastTE
  oseq_sendTE
  oseq_deliverTE
  oseq_receiveTE
  oseq_assignTE
  oseq_callTE
  oseq_choiceTE
  oseq_guardTE

declare oseqp_sos.intros [intro]

subsection "Open structural operational semantics for parallel process expressions "

inductive_set
  oparp_sos :: "ip
                ((ip  's) × 's1, 'm seq_action) transition set
                ('s2, 'm seq_action) transition set
                ((ip  's) × ('s1 × 's2), 'm seq_action) transition set"
  for i :: ip
  and S :: "((ip  's) × 's1, 'm seq_action) transition set"
  and T :: "('s2, 'm seq_action) transition set"
where
    oparleft:  " ((σ, s), a, (σ', s'))  S; m. a  receive m  
                ((σ, (s, t)), a, (σ', (s', t)))  oparp_sos i S T"
  | oparright: " (t, a, t')  T; m. a  send m; σ' i = σ i  
                ((σ, (s, t)), a, (σ', (s, t')))  oparp_sos i S T"
  | oparboth:  " ((σ, s), receive m, (σ', s'))  S; (t, send m, t')  T  
                ((σ, (s, t)), τ, (σ', (s', t')))  oparp_sos i S T"

lemma opar_broadcastTE [elim]:
  "((σ, (s, t)), broadcast m, (σ', (s', t')))  oparp_sos i S T;
    ((σ, s), broadcast m, (σ', s'))  S; t' = t  P;
    (t, broadcast m, t')  T; s' = s; σ' i = σ i  P  P"
  by (ind_cases "((σ, (s, t)), broadcast m, (σ', (s', t')))  oparp_sos i S T") simp_all

lemma opar_groupcastTE [elim]:
  "((σ, (s, t)), groupcast ips m, (σ', (s', t')))  oparp_sos i S T;
    ((σ, s), groupcast ips m, (σ', s'))  S; t' = t  P;
    (t, groupcast ips m, t')  T; s' = s; σ' i = σ i  P  P"
  by (ind_cases "((σ, (s, t)), groupcast ips m, (σ', (s', t')))  oparp_sos i S T") simp_all

lemma opar_unicastTE [elim]:
  "((σ, (s, t)), unicast i m, (σ', (s', t')))  oparp_sos i S T;
    ((σ, s), unicast i m, (σ', s'))  S; t' = t  P;
    (t, unicast i m, t')  T; s' = s; σ' i = σ i  P  P"
  by (ind_cases "((σ, (s, t)), unicast i m, (σ', (s', t')))  oparp_sos i S T") simp_all

lemma opar_notunicastTE [elim]:
  "((σ, (s, t)), notunicast i, (σ', (s', t')))  oparp_sos i S T;
    ((σ, s), notunicast i, (σ', s'))  S; t' = t  P;
    (t, notunicast i, t')  T; s' = s; σ' i = σ i  P  P"
  by (ind_cases "((σ, (s, t)), notunicast i, (σ', (s', t')))  oparp_sos i S T") simp_all

lemma opar_sendTE [elim]:
  "((σ, (s, t)), send m, (σ', (s', t')))  oparp_sos i S T;
    ((σ, s), send m, (σ', s'))  S; t' = t  P  P"
  by (ind_cases "((σ, (s, t)), send m, (σ', (s', t')))  oparp_sos i S T") auto

lemma opar_deliverTE [elim]:
  "((σ, (s, t)), deliver d, (σ', (s', t')))  oparp_sos i S T;
    ((σ, s), deliver d, (σ', s'))  S; t' = t  P;
    (t, deliver d, t')  T; s' = s; σ' i = σ i  P  P"
  by (ind_cases "((σ, (s, t)), deliver d, (σ', (s', t')))  oparp_sos i S T") simp_all

lemma opar_receiveTE [elim]:
  "((σ, (s, t)), receive m, (σ', (s', t')))  oparp_sos i S T;
    (t, receive m, t')  T; s' = s; σ' i = σ i  P  P"
  by (ind_cases "((σ, (s, t)), receive m, (σ', (s', t')))  oparp_sos i S T") auto

inductive_cases opar_tauTE: "((σ, (s, t)), τ, (σ', (s', t')))  oparp_sos i S T"

lemmas oparpTEs =
  opar_broadcastTE
  opar_groupcastTE
  opar_unicastTE
  opar_notunicastTE
  opar_sendTE
  opar_deliverTE
  opar_receiveTE

lemma oparp_sos_cases [elim]:
  assumes "((σ, (s, t)), a, (σ', (s', t')))  oparp_sos i S T"
      and " ((σ, s), a, (σ', s'))  S; m. a  receive m; t' = t   P"
      and " (t, a, t')  T; m. a  send m; s' = s; σ' i = σ i   P"
      and "m.  a = τ; ((σ, s), receive m, (σ', s'))  S; (t, send m, t')  T   P"
    shows "P"
  using assms by cases auto

definition extg :: "('a × 'b) × 'c  'a × 'b × 'c"
where "extg  λ((σ, l1), l2). (σ, (l1, l2))"

lemma extgsimp [simp]:
  "extg ((σ, l1), l2) = (σ, (l1, l2))"
  unfolding extg_def by simp

lemma extg_range_prod: "extg ` (i1 × i2) = {(σ, (s1, s2))|σ s1 s2. (σ, s1)  i1  s2  i2}"
  unfolding image_def extg_def
  by (rule Collect_cong) (auto split: prod.split)

definition
  opar_comp :: "((ip  's) × 's1, 'm seq_action) automaton
                ip
                ('s2, 'm seq_action) automaton
                ((ip  's) × 's1 × 's2, 'm seq_action) automaton"
  ("(_ ⟨⟨⇘_ _)" [102, 0, 103] 102)
where
  "s ⟨⟨i t   init = extg ` (init s × init t), trans = oparp_sos i (trans s) (trans t) "

lemma opar_comp_def':
  "s ⟨⟨i t =  init = {(σ, (sl, tl))|σ sl tl. (σ, sl)  init s  tl  init t},
                trans = oparp_sos i (trans s) (trans t) "
  unfolding opar_comp_def extg_def image_def by (auto split: prod.split)

lemma trans_opar_comp [simp]:
  "trans (s ⟨⟨i t) = oparp_sos i (trans s) (trans t)"
  unfolding opar_comp_def by simp

lemma init_opar_comp [simp]:
  "init (s ⟨⟨i t) = extg ` (init s × init t)"
  unfolding opar_comp_def by simp

subsection "Open structural operational semantics for node expressions "

inductive_set
  onode_sos :: "((ip  's) × 'l, 'm seq_action) transition set
                 ((ip  's) × 'l net_state, 'm node_action) transition set"
  for S :: "((ip  's) × 'l, 'm seq_action) transition set"
where
    onode_bcast:
    "((σ, s), broadcast m, (σ', s'))  S  ((σ, NodeS i s R), R:*cast(m), (σ', NodeS i s' R))  onode_sos S"

  | onode_gcast:
    "((σ, s), groupcast D m, (σ', s'))  S  ((σ, NodeS i s R), (RD):*cast(m), (σ', NodeS i s' R))  onode_sos S"

  | onode_ucast:
    " ((σ, s), unicast d m, (σ', s'))  S; dR   ((σ, NodeS i s R), {d}:*cast(m), (σ', NodeS i s' R))  onode_sos S"

    (* Such assumptions aid later proofs, but they must be justified when transferring results
       to closed systems. *)
  | onode_notucast: " ((σ, s), ¬unicast d, (σ', s'))  S; dR; j. ji  σ' j = σ j 
      ((σ, NodeS i s R), τ, (σ', NodeS i s' R))  onode_sos S"

  | onode_deliver: " ((σ, s), deliver d, (σ', s'))  S; j. ji  σ' j = σ j 
      ((σ, NodeS i s R), i:deliver(d), (σ', NodeS i s' R))  onode_sos S"

  | onode_tau: " ((σ, s), τ, (σ', s'))  S; j. ji  σ' j = σ j 
      ((σ, NodeS i s R),   τ, (σ', NodeS i s' R))  onode_sos S"

  | onode_receive:
    "((σ, s), receive m, (σ', s'))  S  ((σ, NodeS i s R), {i}¬{}:arrive(m), (σ', NodeS i s' R))  onode_sos S"

  | onode_arrive:
    "σ' i = σ i  ((σ, NodeS i s R), {}¬{i}:arrive(m),  (σ', NodeS i s R))  onode_sos S"

  | onode_connect1:
    "σ' i = σ i  ((σ, NodeS i s R), connect(i, i'),    (σ', NodeS i s (R  {i'})))  onode_sos S"

  | onode_connect2:
    "σ' i = σ i  ((σ, NodeS i s R), connect(i', i),    (σ', NodeS i s (R  {i'})))  onode_sos S"

  | onode_disconnect1:
    "σ' i = σ i  ((σ, NodeS i s R), disconnect(i, i'), (σ', NodeS i s (R - {i'})))  onode_sos S"

  | onode_disconnect2:
    "σ' i = σ i  ((σ, NodeS i s R), disconnect(i', i), (σ', NodeS i s (R - {i'})))  onode_sos S"

  | onode_connect_other:
    " i  i'; i  i''; σ' i = σ i   ((σ, NodeS i s R), connect(i', i''),    (σ', NodeS i s R))  onode_sos S"

  | onode_disconnect_other:
    " i  i'; i  i''; σ' i = σ i   ((σ, NodeS i s R), disconnect(i', i''), (σ', NodeS i s R))  onode_sos S"

inductive_cases
      onode_arriveTE [elim]:     "((σ, NodeS i s R), ii¬ni:arrive(m),   (σ', NodeS i' s' R'))  onode_sos S"
  and onode_castTE [elim]:       "((σ, NodeS i s R), RR:*cast(m),        (σ', NodeS i' s' R'))  onode_sos S"
  and onode_deliverTE [elim]:    "((σ, NodeS i s R), ii:deliver(d),      (σ', NodeS i' s' R'))  onode_sos S"
  and onode_connectTE [elim]:    "((σ, NodeS i s R), connect(ii, ii'),   (σ', NodeS i' s' R'))  onode_sos S"
  and onode_disconnectTE [elim]: "((σ, NodeS i s R), disconnect(ii, ii'),(σ', NodeS i' s' R'))  onode_sos S"
  and onode_newpktTE [elim]:     "((σ, NodeS i s R), ii:newpkt(d, di),   (σ', NodeS i' s' R'))  onode_sos S"
  and onode_tauTE [elim]:        "((σ, NodeS i s R), τ,                  (σ', NodeS i' s' R'))  onode_sos S"

lemma oarrives_or_not:
  assumes "((σ, NodeS i s R), ii¬ni:arrive(m), (σ', NodeS i' s' R'))  onode_sos S"
    shows "(ii = {i}  ni = {})  (ii = {}  ni = {i})"
  using assms by rule simp_all

definition
  onode_comp :: "ip
                  ((ip  's) × 'l, 'm seq_action) automaton
                  ip set
                  ((ip  's) × 'l net_state, 'm node_action) automaton"
    ("(_ : (_) : _o)" [0, 0, 0] 104)
where
  "i : onp : Rio   init = {(σ, NodeS i s Ri)|σ s. (σ, s)  init onp},
                      trans = onode_sos (trans onp) "

lemma trans_onode_comp:
  "trans (i : S : Ro) = onode_sos (trans S)"
  unfolding onode_comp_def by simp

lemma init_onode_comp:
  "init (i : S : Ro) = {(σ, NodeS i s R)|σ s. (σ, s)  init S}"
  unfolding onode_comp_def by simp

lemmas onode_comps = trans_onode_comp init_onode_comp

lemma fst_par_onode_comp [simp]:
  "trans (i : s ⟨⟨I t : Ro) = onode_sos (oparp_sos I (trans s) (trans t))"
  unfolding onode_comp_def by simp

lemma init_par_onode_comp [simp]:
  "init (i : s ⟨⟨I t : Ro) = {(σ, NodeS i (s1, s2) R)|σ s1 s2. ((σ, s1), s2)  init s × init t}"
  unfolding onode_comp_def by (simp add: extg_range_prod)

lemma onode_sos_dest_is_net_state:
  assumes "((σ, p), a, s')  onode_sos S"
    shows "σ' i' ζ' R'. s' = (σ', NodeS i' ζ' R')"
  using assms proof -
    assume "((σ, p), a, s')  onode_sos S"
    then obtain σ' i' ζ' R' where "s' = (σ', NodeS i' ζ' R')"
      by (cases s') (auto elim!: onode_sos.cases)
    thus ?thesis by simp
  qed

lemma onode_sos_dest_is_net_state':
  assumes "((σ, NodeS i p R), a, s')  onode_sos S"
    shows "σ' ζ' R'. s' = (σ', NodeS i ζ' R')"
  using assms proof -
    assume "((σ, NodeS i p R), a, s')  onode_sos S"
    then obtain σ' ζ' R' where "s' = (σ', NodeS i ζ' R')"
      by (cases s') (auto elim!: onode_sos.cases)
    thus ?thesis by simp
  qed

lemma onode_sos_dest_is_net_state'':
  assumes "((σ, NodeS i p R), a, (σ', s'))  onode_sos S"
    shows "ζ' R'. s' = NodeS i ζ' R'"
  proof -
    define ns' where "ns' = (σ', s')"
    with assms have "((σ, NodeS i p R), a, ns')  onode_sos S" by simp
    then obtain σ'' ζ' R' where "ns' = (σ'', NodeS i ζ' R')"
      by (metis onode_sos_dest_is_net_state')
    hence "s' = NodeS i ζ' R'" by (simp add: ns'_def)
    thus ?thesis by simp
  qed

lemma onode_sos_src_is_net_state:
  assumes "((σ, p), a, s')  onode_sos S"
    shows "i ζ R. p = NodeS i ζ R"
  using assms proof -
    assume "((σ, p), a, s')  onode_sos S"
    then obtain i ζ R where "p = NodeS i ζ R"
      by (cases s') (auto elim!: onode_sos.cases)
    thus ?thesis by simp
  qed

lemma onode_sos_net_states:
  assumes "((σ, s), a, (σ', s'))  onode_sos S"
    shows "i ζ R ζ' R'. s = NodeS i ζ R  s' = NodeS i ζ' R'"
  proof -
    from assms obtain i ζ R where "s = NodeS i ζ R"
      by (metis onode_sos_src_is_net_state)
    moreover with assms obtain ζ' R' where "s' = NodeS i ζ' R'"
      by (auto dest!: onode_sos_dest_is_net_state')
    ultimately show ?thesis by simp
  qed

lemma node_sos_cases [elim]:
  "((σ, NodeS i p R), a, (σ', NodeS i p' R'))  onode_sos S 
  (m .        a = R:*cast(m);          R' = R; ((σ, p), broadcast m,   (σ', p'))  S   P) 
  (m D.       a = (R  D):*cast(m);    R' = R; ((σ, p), groupcast D m, (σ', p'))  S   P) 
  (d m.       a = {d}:*cast(m);        R' = R; ((σ, p), unicast d m,   (σ', p'))  S; d  R   P) 
  (d.         a = τ;                   R' = R; ((σ, p), ¬unicast d,    (σ', p'))  S; d  R   P) 
  (d.         a = i:deliver(d);        R' = R; ((σ, p), deliver d,     (σ', p'))  S   P) 
  (m.         a = {i}¬{}:arrive(m);    R' = R; ((σ, p), receive m,     (σ', p'))  S   P) 
  (             a = τ;                   R' = R; ((σ, p), τ,             (σ', p'))  S   P) 
  (m.         a = {}¬{i}:arrive(m);    R' = R; p = p'; σ' i = σ i   P) 
  (i i'.      a = connect(i, i');      R' = R  {i'}; p = p'; σ' i = σ i   P) 
  (i i'.      a = connect(i', i);      R' = R  {i'}; p = p'; σ' i = σ i   P) 
  (i i'.      a = disconnect(i, i');   R' = R - {i'}; p = p'; σ' i = σ i   P) 
  (i i'.      a = disconnect(i', i);   R' = R - {i'}; p = p'; σ' i = σ i   P) 
  (i i' i''.  a = connect(i', i'');    R' = R; p = p'; i  i'; i  i''; σ' i = σ i   P) 
  (i i' i''.  a = disconnect(i', i''); R' = R; p = p'; i  i'; i  i''; σ' i = σ i   P) 
  P"
  by (erule onode_sos.cases) (simp | metis)+

subsection "Open structural operational semantics for partial network expressions "

inductive_set
  opnet_sos :: "((ip  's) × 'l net_state, 'm node_action) transition set
                        ((ip  's) × 'l net_state, 'm node_action) transition set
                        ((ip  's) × 'l net_state, 'm node_action) transition set"
  for S :: "((ip  's) × 'l net_state, 'm node_action) transition set"
  and T :: "((ip  's) × 'l net_state, 'm node_action) transition set"
where
    opnet_cast1:
    " ((σ, s), R:*cast(m), (σ', s'))  S; ((σ, t), H¬K:arrive(m), (σ', t'))  T; H  R; K  R = {} 
       ((σ, SubnetS s t), R:*cast(m), (σ', SubnetS s' t'))  opnet_sos S T"

  | opnet_cast2:
    " ((σ, s), H¬K:arrive(m), (σ', s'))  S; ((σ, t), R:*cast(m), (σ', t'))  T;  H  R; K  R = {} 
       ((σ, SubnetS s t), R:*cast(m), (σ', SubnetS s' t'))  opnet_sos S T"

  | opnet_arrive:
    " ((σ, s), H¬K:arrive(m), (σ', s'))  S; ((σ, t), H'¬K':arrive(m), (σ', t'))  T 
       ((σ, SubnetS s t),  (H  H')¬(K  K'):arrive(m), (σ', SubnetS s' t'))  opnet_sos S T"

  | opnet_deliver1:
    "((σ, s), i:deliver(d), (σ', s'))  S
       ((σ, SubnetS s t), i:deliver(d), (σ', SubnetS s' t))  opnet_sos S T"

  | opnet_deliver2:
    " ((σ, t), i:deliver(d), (σ', t'))  T 
       ((σ, SubnetS s t), i:deliver(d), (σ', SubnetS s t'))  opnet_sos S T"

  | opnet_tau1:
    "((σ, s), τ, (σ', s'))  S  ((σ, SubnetS s t), τ, (σ', SubnetS s' t))  opnet_sos S T"

  | opnet_tau2:
    "((σ, t), τ, (σ', t'))  T  ((σ, SubnetS s t), τ, (σ', SubnetS s t'))  opnet_sos S T"

  | opnet_connect:
    " ((σ, s), connect(i, i'), (σ', s'))  S; ((σ, t), connect(i, i'), (σ', t'))  T 
       ((σ, SubnetS s t), connect(i, i'), (σ', SubnetS s' t'))  opnet_sos S T"

  | opnet_disconnect:
    " ((σ, s), disconnect(i, i'), (σ', s'))  S; ((σ, t), disconnect(i, i'), (σ', t'))  T 
       ((σ, SubnetS s t), disconnect(i, i'), (σ', SubnetS s' t'))  opnet_sos S T"

inductive_cases opartial_castTE [elim]:       "((σ, s), R:*cast(m), (σ', s'))  opnet_sos S T"
            and opartial_arriveTE [elim]:     "((σ, s), H¬K:arrive(m), (σ', s'))  opnet_sos S T"
            and opartial_deliverTE [elim]:    "((σ, s), i:deliver(d), (σ', s'))  opnet_sos S T"
            and opartial_tauTE [elim]:        "((σ, s), τ, (σ', s'))  opnet_sos S T"
            and opartial_connectTE [elim]:    "((σ, s), connect(i, i'), (σ', s'))  opnet_sos S T"
            and opartial_disconnectTE [elim]: "((σ, s), disconnect(i, i'), (σ', s'))  opnet_sos S T"
            and opartial_newpktTE [elim]:     "((σ, s), i:newpkt(d, di), (σ', s'))  opnet_sos S T"

fun opnet :: "(ip  ((ip  's) × 'l, 'm seq_action) automaton)
               net_tree  ((ip  's) × 'l net_state, 'm node_action) automaton"
where
    "opnet onp (i; Ri)  =  i : onp i : Rio"
  | "opnet onp (p1  p2) =  init = {(σ, SubnetS s1 s2) |σ s1 s2.
                                        (σ, s1)  init (opnet onp p1)
                                       (σ, s2)  init (opnet onp p2)
                                       net_ips s1  net_ips s2 = {}},
                             trans = opnet_sos (trans (opnet onp p1)) (trans (opnet onp p2)) "

lemma opnet_node_init [elim, simp]:
  assumes "(σ, s)  init (opnet onp i; R)"
    shows "(σ, s)  { (σ, NodeS i ns R) |σ ns. (σ, ns)  init (onp i)}"
  using assms by (simp add: onode_comp_def)

lemma opnet_node_init' [elim]:
 assumes "(σ, s)  init (opnet onp i; R)"
 obtains ns where "s = NodeS i ns R"
             and "(σ, ns)  init (onp i)"
   using assms by (auto simp add: onode_comp_def)

lemma opnet_node_trans [elim, simp]:
  assumes "(s, a, s')  trans (opnet onp i; R)"
    shows "(s, a, s')  onode_sos (trans (onp i))"
  using assms by (simp add: trans_onode_comp)

subsection "Open structural operational semantics for complete network expressions "

inductive_set
  ocnet_sos :: "((ip  's) × 'l net_state, 'm::msg node_action) transition set
                          ((ip  's) × 'l net_state, 'm node_action) transition set"
  for S :: "((ip  's) × 'l net_state, 'm node_action) transition set"
where
    ocnet_connect:
    " ((σ, s), connect(i, i'), (σ', s'))  S; j. j  net_ips s  (σ' j = σ j) 
      ((σ, s), connect(i, i'), (σ', s'))  ocnet_sos S"

  | ocnet_disconnect:
    " ((σ, s), disconnect(i, i'), (σ', s'))  S; j. j  net_ips s  (σ' j = σ j) 
      ((σ, s), disconnect(i, i'), (σ', s'))  ocnet_sos S"

  | ocnet_cast:
    " ((σ, s), R:*cast(m), (σ', s'))  S; j. j  net_ips s  (σ' j = σ j) 
      ((σ, s), τ, (σ', s'))  ocnet_sos S"

  | ocnet_tau:  
    " ((σ, s), τ, (σ', s'))  S; j. j  net_ips s  (σ' j = σ j) 
      ((σ, s), τ, (σ', s'))  ocnet_sos S"

  | ocnet_deliver:
    " ((σ, s), i:deliver(d), (σ', s'))  S; j. j  net_ips s  (σ' j = σ j) 
      ((σ, s), i:deliver(d), (σ', s'))  ocnet_sos S"

  | ocnet_newpkt:
    " ((σ, s), {i}¬K:arrive(newpkt(d, di)), (σ', s'))  S; j. j  net_ips s  (σ' j = σ j) 
      ((σ, s), i:newpkt(d, di), (σ', s'))  ocnet_sos S"

inductive_cases oconnect_completeTE: "((σ, s), connect(i, i'), (σ', s'))  ocnet_sos S"
            and odisconnect_completeTE: "((σ, s), disconnect(i, i'), (σ', s'))  ocnet_sos S"
            and otau_completeTE: "((σ, s), τ, (σ', s'))  ocnet_sos S"
            and odeliver_completeTE: "((σ, s), i:deliver(d), (σ', s'))  ocnet_sos S"
            and onewpkt_completeTE: "((σ, s), i:newpkt(d, di), (σ', s'))  ocnet_sos S"

lemmas ocompleteTEs = oconnect_completeTE
                      odisconnect_completeTE
                      otau_completeTE
                      odeliver_completeTE
                      onewpkt_completeTE

lemma ocomplete_no_cast [simp]:
  "((σ, s), R:*cast(m), (σ', s'))  ocnet_sos T"
  proof
    assume "((σ, s), R:*cast(m), (σ', s'))  ocnet_sos T"
    hence "R:*cast(m)  R:*cast(m)"
     by (rule ocnet_sos.cases) auto
    thus False by simp
  qed

lemma ocomplete_no_arrive [simp]:
  "((σ, s), ii¬ni:arrive(m), (σ', s'))  ocnet_sos T"
  proof
    assume "((σ, s), ii¬ni:arrive(m), (σ', s'))  ocnet_sos T"
    hence "ii¬ni:arrive(m)  ii¬ni:arrive(m)"
     by (rule ocnet_sos.cases) auto
    thus False by simp
  qed

lemma ocomplete_no_change [elim]:
  assumes "((σ, s), a, (σ', s'))  ocnet_sos T"
      and "j  net_ips s"
    shows "σ' j = σ j"
  using assms by cases simp_all

lemma ocomplete_transE [elim]:
  assumes "((σ, ζ), a, (σ', ζ'))  ocnet_sos (trans (opnet onp n))"
  obtains a' where "((σ, ζ), a', (σ', ζ'))  trans (opnet onp n)"
  using assms by (cases a) (auto elim!: ocompleteTEs [simplified])

abbreviation
  oclosed :: "((ip  's) × 'l net_state, ('m::msg) node_action) automaton
               ((ip  's) × 'l net_state, 'm node_action) automaton"
where
  "oclosed  (λA. A  trans := ocnet_sos (trans A) )"

end

Theory OAWN_SOS_Labels

(*  Title:       OAWN_SOS_Labels.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Configure the inv-cterms tactic for open sequential processes"

theory OAWN_SOS_Labels
imports OAWN_SOS Inv_Cterms
begin

lemma oelimder_guard:
  assumes "p = {l}fg qq"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' where "p = {l}fg p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma oelimder_assign:
  assumes "p = {l}fa qq"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' where "p = {l}fa p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma oelimder_ucast:
  assumes "p = {l}unicast(fip, fmsg).q1  q2"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' pp' where "p = {l}unicast(fip, fmsg).p'  pp'"
                   and "case a of unicast _ _  l'  labels Γ q1
                                        | _  l'  labels Γ q2"
  using assms by simp (erule oseqpTEs, auto)

lemma oelimder_bcast:
  assumes "p = {l}broadcast(fmsg).qq"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' where "p = {l}broadcast(fmsg). p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma oelimder_gcast:
  assumes "p = {l}groupcast(fips, fmsg).qq"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' where "p = {l}groupcast(fips, fmsg). p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma oelimder_send:
  assumes "p = {l}send(fmsg).qq"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' where "p = {l}send(fmsg). p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma oelimder_deliver:
  assumes "p = {l}deliver(fdata).qq"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' where "p = {l}deliver(fdata).p'"
               and "l'  labels Γ qq"
  using assms by auto

lemma oelimder_receive:
  assumes "p = {l}receive(fmsg).qq"
      and "l'  labels Γ q"
      and "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  obtains p' where "p = {l}receive(fmsg).p'"
               and "l'  labels Γ qq"
  using assms by auto

lemmas oelimders =
   oelimder_guard
   oelimder_assign
   oelimder_ucast
   oelimder_bcast
   oelimder_gcast
   oelimder_send
   oelimder_deliver
   oelimder_receive

declare
  oseqpTEs [cterms_seqte]
  oelimders [cterms_elimders]

end

Theory OPnet

(*  Title:       OPnet.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lemmas for open partial networks"

theory OPnet
imports OAWN_SOS OInvariants
begin

text ‹
  These lemmas mostly concern the preservation of node structure by @{term opnet_sos} transitions.
›

lemma opnet_maintains_dom:
  assumes "((σ, ns), a, (σ', ns'))  trans (opnet np p)"
    shows "net_ips ns = net_ips ns'"
  using assms proof (induction p arbitrary: σ ns a σ' ns')
    fix i R σ ns a σ' ns'
    assume "((σ, ns), a, (σ', ns'))  trans (opnet np i; R)"
    hence "((σ, ns), a, (σ', ns'))  onode_sos (trans (np i))" ..
    thus "net_ips ns = net_ips ns'"
      by (simp add: net_ips_is_dom_netmap)
         (erule onode_sos.cases, simp_all)
  next
    fix p1 p2 σ ns a σ' ns'
    assume "σ ns a σ' ns'. ((σ, ns), a, (σ', ns'))  trans (opnet np p1)  net_ips ns = net_ips ns'"
       and "σ ns a σ' ns'. ((σ, ns), a, (σ', ns'))  trans (opnet np p2)  net_ips ns = net_ips ns'"
       and "((σ, ns), a, (σ', ns'))  trans (opnet np (p1  p2))"
    thus "net_ips ns = net_ips ns'"
      by simp (erule opnet_sos.cases, simp_all)
  qed

lemma opnet_net_ips_net_tree_ips:
  assumes "(σ, ns)  oreachable (opnet np p) S U"
    shows "net_ips ns = net_tree_ips p"
  using assms proof (induction rule: oreachable_pair_induct)
    fix σ s
    assume "(σ, s)  init (opnet np p)"
    thus "net_ips s = net_tree_ips p"
    proof (induction p arbitrary: σ s)
      fix p1 p2 σ s
      assume IH1: "(σ s. (σ, s)  init (opnet np p1)  net_ips s = net_tree_ips p1)"
         and IH2: "(σ s. (σ, s)  init (opnet np p2)  net_ips s = net_tree_ips p2)"
         and "(σ, s)  init (opnet np (p1  p2))"
      thus "net_ips s = net_tree_ips (p1  p2)"
        by (clarsimp simp add: net_ips_is_dom_netmap)
           (metis Un_commute)
    qed (clarsimp simp add: onode_comps)
  next
    fix σ s σ' s' a
    assume "(σ, s)  oreachable (opnet np p) S U"
       and "net_ips s = net_tree_ips p"
       and "((σ, s), a, (σ', s'))  trans (opnet np p)"
       and "S σ σ' a"
    thus "net_ips s' = net_tree_ips p"
      by (simp add: net_ips_is_dom_netmap)
         (metis net_ips_is_dom_netmap opnet_maintains_dom)
  qed simp

lemma opnet_net_ips_net_tree_ips_init:
  assumes "(σ, ns)  init (opnet np p)"
    shows "net_ips ns = net_tree_ips p"
  using assms(1) by (rule oreachable_init [THEN opnet_net_ips_net_tree_ips])

lemma opartial_net_preserves_subnets:
  assumes "((σ, SubnetS s t), a, (σ', st'))  opnet_sos (trans (opnet np p1)) (trans (opnet np p2))"
    shows "s' t'. st' = SubnetS s' t'"
  using assms by cases simp_all

lemma net_par_oreachable_is_subnet:
  assumes "(σ, st)  oreachable (opnet np (p1  p2)) S U"
    shows "s t. st = SubnetS s t"
  proof -
    define p where "p = (σ, st)"
    with assms have "p  oreachable (opnet np (p1  p2)) S U" by simp
    hence "σ s t. p = (σ, SubnetS s t)"
      by induct (auto dest!: opartial_net_preserves_subnets)
    with p_def show ?thesis by simp
  qed

end

Theory ONode_Lifting

(*  Title:       ONode_Lifting.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lifting rules for (open) nodes"

theory ONode_Lifting
imports AWN OAWN_SOS OInvariants
begin

lemma node_net_state':
  assumes "s  oreachable (i : T : Rio) S U"
    shows "σ ζ R. s = (σ, NodeS i ζ R)"
  using assms proof induction
    fix s
    assume "s  init (i : T : Rio)"
    then obtain σ ζ where "s = (σ, NodeS i ζ Ri)"
      by (auto simp: onode_comps)
    thus "σ ζ R. s = (σ, NodeS i ζ R)" by auto
  next
    fix s a σ'
    assume rt: "s  oreachable (i : T : Rio) S U"
       and ih: "σ ζ R. s = (σ, NodeS i ζ R)"
       and "U (fst s) σ'"
    then obtain σ ζ R
      where "(σ, NodeS i ζ R)   oreachable (i : T : Rio) S U"
        and "U σ σ'" and "snd s = NodeS i ζ R" by auto
    from this(1-2)
      have "(σ', NodeS i ζ R)  oreachable (i : T : Rio) S U"
        by - (erule(1) oreachable_other')
    with ‹snd s = NodeS i ζ R show "σ ζ R. (σ', snd s) = (σ, NodeS i ζ R)" by simp
  next
    fix s a s'
    assume rt: "s  oreachable (i : T : Rio) S U"
       and ih: "σ ζ R. s = (σ, NodeS i ζ R)"
       and tr: "(s, a, s')  trans (i : T : Rio)"
       and "S (fst s) (fst s') a"
     from ih obtain σ ζ R where "s = (σ, NodeS i ζ R)" by auto
     with tr have "((σ, NodeS i ζ R), a, s')  onode_sos (trans T)"
       by (simp add: onode_comps)
     then obtain σ' ζ' R' where "s' = (σ', NodeS i ζ' R')"
       using onode_sos_dest_is_net_state' by metis
     with tr s = (σ, NodeS i ζ R) show "σ ζ R. s' = (σ, NodeS i ζ R)"
       by simp
  qed

lemma node_net_state:
  assumes "(σ, s)  oreachable (i : T : Rio) S U"
    shows "ζ R. s = NodeS i ζ R"
  using assms
  by (metis Pair_inject node_net_state')

lemma node_net_state_trans [elim]:
  assumes sor: "(σ, s)  oreachable (i : ζi : Rio) S U"
      and str: "((σ, s), a, (σ', s'))  trans (i : ζi : Rio)"
  obtains ζ R ζ' R'
    where "s = NodeS i ζ R"
      and "s' = NodeS i ζ' R'"
  proof -
    assume *: "ζ R ζ' R'. s = NodeS i ζ R  s' = NodeS i ζ' R'  thesis"
    from sor obtain ζ R where "s = NodeS i ζ R"
      by (metis node_net_state)
    moreover with str obtain ζ' R' where "s' = NodeS i ζ' R'"
      by (simp only: onode_comps)
         (metis onode_sos_dest_is_net_state'')
    ultimately show thesis by (rule *)
  qed

lemma nodemap_induct' [consumes, case_names init other local]:
  assumes "(σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U"
      and init: "σ ζ. (σ, NodeS ii ζ Ri)  init (ii : T : Rio)  P (σ, NodeS ii ζ Ri)"
      and other: "σ ζ R σ' a.
                   (σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U;
                    U σ σ'; P (σ, NodeS ii ζ R)   P (σ', NodeS ii ζ R)"
      and local: "σ ζ R σ' ζ' R' a.
                   (σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U;
                    ((σ, NodeS ii ζ R), a, (σ', NodeS ii ζ' R'))  trans (ii : T : Rio);
                    S σ σ' a; P (σ, NodeS ii ζ R)   P (σ', NodeS ii ζ' R')"
    shows "P (σ, NodeS ii ζ R)"
  using assms(1) proof induction
    fix s
    assume "s  init (ii : T : Rio)"
    hence "s  oreachable (ii : T : Rio) S U"
      by (rule oreachable_init)
    with s  init (ii : T : Rio) obtain σ ζ where "s = (σ, NodeS ii ζ Ri)"
      by (simp add: onode_comps) metis
    with s  init (ii : T : Rio) and init show "P s" by simp
  next
    fix s a σ'
    assume sr: "s  oreachable (ii : T : Rio) S U"
       and "U (fst s) σ'"
       and "P s"
    from sr obtain σ ζ R where "s = (σ, NodeS ii ζ R)"
      using node_net_state' by metis
    with sr U (fst s) σ' P s show "P (σ', snd s)"
    by simp (metis other)
  next
    fix s a s'
    assume sr: "s  oreachable (ii : T : Rio) S U"
       and tr: "(s, a, s')  trans (ii : T : Rio)"
       and "S (fst s) (fst s') a"
       and "P s"
    from this(1-3) have "s'  oreachable (ii : T : Rio) S U"
      by - (erule(2) oreachable_local)
    then obtain σ' ζ' R' where [simp]: "s' = (σ', NodeS ii ζ' R')"
      using node_net_state' by metis
    from sr and P s obtain σ ζ R
      where [simp]: "s = (σ, NodeS ii ζ R)"
        and A1: "(σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U"
        and A4: "P (σ, NodeS ii ζ R)"
      using node_net_state' by metis
    with tr and S (fst s) (fst s') a
      have A2: "((σ, NodeS ii ζ R), a, (σ', NodeS ii ζ' R'))  trans (ii : T : Rio)"
       and A3: "S σ σ' a" by simp_all
    from A1 A2 A3 A4 have "P (σ', NodeS ii ζ' R')" by (rule local)
    thus "P s'" by simp
  qed

lemma nodemap_induct [consumes, case_names init step]:
  assumes "(σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U"
      and init: "σ ζ. (σ, NodeS ii ζ Ri)  init (ii : T : Rio)  P σ ζ Ri"
      and other: "σ ζ R σ' a.
                   (σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U;
                    U σ σ'; P σ ζ R   P σ' ζ R"
      and local: "σ ζ R σ' ζ' R' a.
                   (σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U;
                    ((σ, NodeS ii ζ R), a, (σ', NodeS ii ζ' R'))  trans (ii : T : Rio);
                    S σ σ' a; P σ ζ R   P σ' ζ' R'"
    shows "P σ ζ R"
  using assms(1) proof (induction "(σ, NodeS ii ζ R)" arbitrary: σ ζ R)
    fix σ ζ R
    assume a1: "(σ, NodeS ii ζ R)  init (ii : T : Rio)"
    hence "R = Ri" by (simp add: init_onode_comp)
    with a1 have "(σ, NodeS ii ζ Ri)  init (ii : T : Rio)" by simp
    with init and R = Ri show "P σ ζ R" by simp
  next
    fix st a σ' ζ' R'
    assume "st  oreachable (ii : T : Rio) S U"
       and tr: "(st, a, (σ', NodeS ii ζ' R'))  trans (ii : T : Rio)"
       and "S (fst st) (fst (σ', NodeS ii ζ' R')) a"
       and IH: "σ ζ R. st = (σ, NodeS ii ζ R)  P σ ζ R"
    from this(1) obtain σ ζ R where "st = (σ, NodeS ii ζ R)"
                                and "(σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U"
      by (metis node_net_state')
    note this(2)
    moreover from tr and st = (σ, NodeS ii ζ R)
      have "((σ, NodeS ii ζ R), a, (σ', NodeS ii ζ' R'))  trans (ii : T : Rio)" by simp
    moreover from S (fst st) (fst (σ', NodeS ii ζ' R')) a and st = (σ, NodeS ii ζ R)
      have "S σ σ' a" by simp
    moreover from IH and st = (σ, NodeS ii ζ R) have "P σ ζ R" .
    ultimately show "P σ' ζ' R'" by (rule local)
  next
    fix st σ' ζ R
    assume "st  oreachable (ii : T : Rio) S U"
       and "U (fst st) σ'"
       and "snd st = NodeS ii ζ R"
       and IH: "σ ζ R. st = (σ, NodeS ii ζ R)  P σ ζ R"
    from this(1,3) obtain σ where "st = (σ, NodeS ii ζ R)"
                              and "(σ, NodeS ii ζ R)  oreachable (ii : T : Rio) S U"
      by (metis surjective_pairing)
    note this(2)
    moreover from U (fst st) σ' and st = (σ, NodeS ii ζ R) have "U σ σ'" by simp
    moreover from IH and st = (σ, NodeS ii ζ R) have "P σ ζ R" .
    ultimately show "P σ' ζ R" by (rule other)
  qed

lemma node_addressD [dest, simp]:
  assumes "(σ, NodeS i ζ R)  oreachable (ii : T : Rio) S U"
    shows "i = ii"
  using assms by (clarsimp dest!: node_net_state')

lemma node_proc_reachable [dest]:
  assumes "(σ, NodeS i ζ R)  oreachable (ii : T : Rio)
                                         (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      and sgivesu: "ξ ξ'. S ξ ξ'  U ξ ξ'"
    shows "(σ, ζ)  oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
  proof -
    from assms(1) have "(σ, NodeS ii ζ R)  oreachable (ii : T : Rio)
                                             (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      by - (frule node_addressD, simp)
    thus ?thesis
    proof (induction rule: nodemap_induct)
      fix σ ζ
      assume "(σ, NodeS ii ζ Ri)  init (ii : T : Rio)"
      hence "(σ, ζ)  init T" by (auto simp: onode_comps)
      thus "(σ, ζ)  oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
        by (rule oreachable_init)
    next
      fix σ ζ R σ' ζ' R' a
      assume "other U {ii} σ σ'"
         and "(σ, ζ)  oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      thus "(σ', ζ)  oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
        by - (rule oreachable_other')
    next
      fix σ ζ R σ' ζ' R' a
      assume rs: "(σ, NodeS ii ζ R)  oreachable (ii : T : Rio)
                                         (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
         and tr: "((σ, NodeS ii ζ R), a, (σ', NodeS ii ζ' R'))  trans (ii : T : Rio)"
         and ow: "otherwith S {ii} (oarrivemsg I) σ σ' a"
         and ih: "(σ, ζ)  oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"

      from ow have *: "σ' ii = σ ii  other U {ii} σ σ'"
        by (clarsimp elim!: otherwithE) (rule otherI, simp_all, metis sgivesu)
      from tr have "((σ, NodeS ii ζ R), a, (σ', NodeS ii ζ' R'))  onode_sos (trans T)"
        by (simp add: onode_comps)
      thus "(σ', ζ')  oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      proof cases
        case onode_bcast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_gcast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_ucast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_notucast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_deliver
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_tau
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_receive
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case (onode_arrive m)
        hence "ζ' = ζ" and "σ' ii = σ ii" by auto
        from this(2) have "other U {ii} σ σ'" by (rule *)
        with ih and ζ' = ζ show ?thesis by auto
      next
        case onode_connect1
        hence "ζ' = ζ" and "σ' ii = σ ii" by auto
        from this(2) have "other U {ii} σ σ'" by (rule *)
        with ih and ζ' = ζ show ?thesis by auto
      next
        case onode_connect2
        hence "ζ' = ζ" and "σ' ii = σ ii" by auto
        from this(2) have "other U {ii} σ σ'" by (rule *)
        with ih and ζ' = ζ show ?thesis by auto
      next
        case onode_connect_other
        hence "ζ' = ζ" and "σ' ii = σ ii" by auto
        from this(2) have "other U {ii} σ σ'" by (rule *)
        with ih and ζ' = ζ show ?thesis by auto
      next
        case onode_disconnect1
        hence "ζ' = ζ" and "σ' ii = σ ii" by auto
        from this(2) have "other U {ii} σ σ'" by (rule *)
        with ih and ζ' = ζ show ?thesis by auto
      next
        case onode_disconnect2
        hence "ζ' = ζ" and "σ' ii = σ ii" by auto
        from this(2) have "other U {ii} σ σ'" by (rule *)
        with ih and ζ' = ζ show ?thesis by auto
      next
        case onode_disconnect_other
        hence "ζ' = ζ" and "σ' ii = σ ii" by auto
        from this(2) have "other U {ii} σ σ'" by (rule *)
        with ih and ζ' = ζ show ?thesis by auto
      qed
    qed
  qed

lemma node_proc_reachable_statelessassm [dest]:
  assumes "(σ, NodeS i ζ R)  oreachable (ii : T : Rio)
                                         (otherwith (λ_ _. True) {ii} (oarrivemsg I))
                                         (other (λ_ _. True) {ii})"
    shows "(σ, ζ)  oreachable T
                               (otherwith (λ_ _. True) {ii} (orecvmsg I)) (other (λ_ _. True) {ii})"
  using assms
  by (rule node_proc_reachable) simp_all

lemma node_lift:
  assumes "T  (otherwith S {ii} (orecvmsg I), other U {ii} →) global P"
      and "ξ ξ'. S ξ ξ'  U ξ ξ'"
    shows "ii : T : Rio  (otherwith S {ii} (oarrivemsg I), other U {ii} →) global P"
  proof (rule oinvariant_oreachableI)
    fix σ ζ
    assume "(σ, ζ)  oreachable (ii : T : Rio) (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
    moreover then obtain i s R where "ζ = NodeS i s R"
      by (metis node_net_state)
    ultimately have "(σ, NodeS i s R)  oreachable (ii : T : Rio)
                                                   (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      by simp
    hence "(σ, s)  oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      by - (erule node_proc_reachable, erule assms(2))
    with assms(1) show "global P (σ, ζ)"
      by (metis fst_conv globalsimp oinvariantD)
  qed

lemma node_lift_step [intro]:
  assumes pinv: "T A (otherwith S {i} (orecvmsg I), other U {i} →) globala (λ(σ, _, σ'). Q σ σ')"
      and other: "σ σ'. other U {i} σ σ'  Q σ σ'"
      and sgivesu: "ξ ξ'. S ξ ξ'  U ξ ξ'"
    shows "i : T : Rio A (otherwith S {i} (oarrivemsg I), other U {i} →)
                            globala (λ(σ, _, σ'). Q σ σ')"
    (is "_ A (?S, ?U →) _")
  proof (rule ostep_invariantI, simp)
    fix σ s a σ' s'
    assume rs: "(σ, s)  oreachable (i : T : Rio) ?S ?U"
       and tr: "((σ, s), a, (σ', s'))  trans (i : T : Rio)"
       and ow: "?S σ σ' a"
    from ow have *: "σ' i = σ i  other U {i} σ σ'"
      by (clarsimp elim!: otherwithE) (rule otherI, simp_all, metis sgivesu)
    from rs tr obtain ζ R
      where [simp]: "s = NodeS i ζ R"
        and "(σ, NodeS i ζ R)  oreachable (i : T : Rio) ?S ?U"
      by (metis node_net_state)
    from this(2) have or: "(σ, ζ)  oreachable T (otherwith S {i} (orecvmsg I)) ?U"
      by (rule node_proc_reachable [OF _ assms(3)])
    from tr have "((σ, NodeS i ζ R), a, (σ', s'))  onode_sos (trans T)"
      by (simp add: onode_comps)
    thus "Q σ σ'"
    proof cases
      fix m ζ'
      assume "a = R:*cast(m)"
         and tr': "((σ, ζ), broadcast m, (σ', ζ'))  trans T"
      from this(1) and ?S σ σ' a have "otherwith S {i} (orecvmsg I) σ σ' (broadcast m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix D m ζ'
      assume "a = (R  D):*cast(m)"
         and tr': "((σ, ζ), groupcast D m, (σ', ζ'))  trans T"
      from this(1) and ?S σ σ' a have "otherwith S {i} (orecvmsg I) σ σ' (groupcast D m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d m ζ'
      assume "a = {d}:*cast(m)"
         and tr': "((σ, ζ), unicast d m, (σ', ζ'))  trans T"
      from this(1) and ?S σ σ' a have "otherwith S {i} (orecvmsg I) σ σ' (unicast d m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d ζ'
      assume "a = τ"
         and tr': "((σ, ζ), ¬unicast d, (σ', ζ'))  trans T"
      from this(1) and ?S σ σ' a have "otherwith S {i} (orecvmsg I) σ σ' (¬unicast d)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d ζ'
      assume "a = i:deliver(d)"
         and tr': "((σ, ζ), deliver d, (σ', ζ'))  trans T"
      from this(1) and ?S σ σ' a have "otherwith S {i} (orecvmsg I) σ σ' (deliver d)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix ζ'
      assume "a = τ"
         and tr': "((σ, ζ), τ, (σ', ζ'))  trans T"
      from this(1) and ?S σ σ' a have "otherwith S {i} (orecvmsg I) σ σ' τ"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix m ζ'
      assume "a = {i}¬{}:arrive(m)"
         and tr': "((σ, ζ), receive m, (σ', ζ'))  trans T"
      from this(1) and ?S σ σ' a have "otherwith S {i} (orecvmsg I) σ σ' (receive m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix m
      assume "a = {}¬{i}:arrive(m)"
         and "σ' i = σ i"
      from this(2) have "other U {i} σ σ'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = connect(i, i')"
         and "σ' i = σ i"
      from this(2) have "other U {i} σ σ'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = connect(i', i)"
         and "σ' i = σ i"
      from this(2) have "other U {i} σ σ'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i' i''
      assume "a = connect(i', i'')"
         and "σ' i = σ i"
      from this(2) have "other U {i} σ σ'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = disconnect(i, i')"
         and "σ' i = σ i"
      from this(2) have "other U {i} σ σ'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = disconnect(i', i)"
         and "σ' i = σ i"
      from this(2) have "other U {i} σ σ'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i' i''
      assume "a = disconnect(i', i'')"
         and "σ' i = σ i"
      from this(2) have "other U {i} σ σ'" by (rule *)
      thus ?thesis by (rule other)
    qed
  qed

lemma node_lift_step_statelessassm [intro]:
  assumes "T A (λσ _. orecvmsg I σ, other (λ_ _. True) {i} →)
                       globala (λ(σ, _, σ'). Q (σ i) (σ' i))"
      and "ξ. Q ξ ξ"
    shows "i : T : Rio A (λσ _. oarrivemsg I σ, other (λ_ _. True) {i} →)
                            globala (λ(σ, _, σ'). Q (σ i) (σ' i))"
  proof -
    from assms(1)
      have "T A (otherwith (λ_ _. True) {i} (orecvmsg I), other (λ_ _. True) {i} →)
                  globala (λ(σ, _, σ'). Q (σ i) (σ' i))"
        by rule auto
    with assms(2) have "i : T : Rio A (otherwith (λ_ _. True) {i} (oarrivemsg I),
                                          other (λ_ _. True) {i} →)
                                         globala (λ(σ, _, σ'). Q (σ i) (σ' i))"
      by - (rule node_lift_step, auto)
    thus ?thesis by rule auto
  qed

lemma node_lift_anycast [intro]:
  assumes pinv: "T A (otherwith S {i} (orecvmsg I), other U {i} →)
                       globala (λ(σ, a, σ'). anycast (Q σ σ') a)"
      and "ξ ξ'. S ξ ξ'  U ξ ξ'"
    shows "i : T : Rio A (otherwith S {i} (oarrivemsg I), other U {i} →)
                            globala (λ(σ, a, σ'). castmsg (Q σ σ') a)"
    (is "_ A (?S, ?U →) _")
  proof (rule ostep_invariantI, simp)
    fix σ s a σ' s'
    assume rs: "(σ, s)  oreachable (i : T : Rio) ?S ?U"
       and tr: "((σ, s), a, (σ', s'))  trans (i : T : Rio)"
       and "?S σ σ' a"
    from this(1-2) obtain ζ R
      where [simp]: "s = NodeS i ζ R"
        and "(σ, NodeS i ζ R)  oreachable (i : T : Rio) ?S ?U"
      by (metis node_net_state)
    from this(2) have "(σ, ζ)  oreachable T (otherwith S {i} (orecvmsg I)) ?U"
      by (rule node_proc_reachable [OF _ assms(2)])
    moreover from tr have "((σ, NodeS i ζ R), a, (σ', s'))  onode_sos (trans T)"
      by (simp add: onode_comps)
    ultimately show "castmsg (Q σ σ') a" using ?S σ σ' a
      by - (erule onode_sos.cases, auto elim!: otherwithE dest!: ostep_invariantD [OF pinv])
  qed

lemma node_lift_anycast_statelessassm [intro]:
  assumes pinv: "T A (λσ _. orecvmsg I σ, other (λ_ _. True) {i} →)
                       globala (λ(σ, a, σ'). anycast (Q σ σ') a)"
    shows "i : T : Rio A (λσ _. oarrivemsg I σ, other (λ_ _. True) {i} →)
                            globala (λ(σ, a, σ'). castmsg (Q σ σ') a)"
    (is "_ A (?S, _ →) _")
  proof -
    from assms(1)
      have "T A (otherwith (λ_ _. True) {i} (orecvmsg I), other (λ_ _. True) {i} →)
                  globala (λ(σ, a, σ'). anycast (Q σ σ') a)"
        by rule auto
    hence "i : T : Rio A (otherwith (λ_ _. True) {i} (oarrivemsg I), other (λ_ _. True) {i} →)
                            globala (λ(σ, a, σ'). castmsg (Q σ σ') a)"
      by (rule node_lift_anycast) simp_all
    thus ?thesis
      by rule auto
  qed

lemma node_local_deliver:
  "i : ζi : Rio A (S, U →) globala (λ(_, a, _). j. ji  (d. a  j:deliver(d)))"
  proof (rule ostep_invariantI, simp)
    fix σ s a σ' s'
    assume 1: "(σ, s)  oreachable (i : ζi : Rio) S U"
       and 2: "((σ, s), a, (σ', s'))  trans (i : ζi : Rio)"
       and "S σ σ' a"
    moreover from 1 2 obtain ζ R ζ' R' where "s = NodeS i ζ R" and "s' = NodeS i ζ' R'" ..
    ultimately show "j. ji  (d. a  j:deliver(d))"
      by (cases a) (auto simp add: onode_comps)
  qed

lemma node_tau_deliver_unchanged:
  "i : ζi : Rio A (S, U →) globala (λ(σ, a, σ'). a = τ  (i d. a = i:deliver(d))
                                                      (j. ji  σ' j = σ j))"
  proof (rule ostep_invariantI, clarsimp simp only: globalasimp snd_conv fst_conv)
    fix σ s a σ' s' j
    assume 1: "(σ, s)  oreachable (i : ζi : Rio) S U"
       and 2: "((σ, s), a, (σ', s'))  trans (i : ζi : Rio)"
       and "S σ σ' a"
       and "a = τ  (i d. a = i:deliver(d))"
       and "j  i"
    moreover from 1 2 obtain ζ R ζ' R' where "s = NodeS i ζ R" and "s' = NodeS i ζ' R'" ..
    ultimately show "σ' j = σ j"
      by (cases a) (auto simp del: step_node_tau simp add: onode_comps)
  qed

end

Theory OPnet_Lifting

(*  Title:       OPnet_Lifting.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lifting rules for (open) partial networks"

theory OPnet_Lifting
imports ONode_Lifting OAWN_SOS OPnet
begin

lemma oreachable_par_subnet_induct [consumes, case_names init other local]:
  assumes "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) S U"
      and init: "σ s t. (σ, SubnetS s t)  init (opnet onp (p1  p2))  P σ s t"
      and other: "σ s t σ'.  (σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) S U;
                                U σ σ'; P σ s t   P σ' s t"
      and local: "σ s t σ' s' t' a.  (σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) S U;
                    ((σ, SubnetS s t), a, (σ', SubnetS s' t'))  trans (opnet onp (p1  p2));
                    S σ σ' a; P σ s t   P σ' s' t'"
    shows "P σ s t"
  using assms(1) proof (induction "(σ, SubnetS s t)" arbitrary: s t σ)
    fix s t σ
    assume "(σ, SubnetS s t)  init (opnet onp (p1  p2))"
    with init show "P σ s t" .
  next
    fix st a s' t' σ'
    assume "st  oreachable (opnet onp (p1  p2)) S U"
       and tr: "(st, a, (σ', SubnetS s' t'))  trans (opnet onp (p1  p2))"
       and "S (fst st) (fst (σ', SubnetS s' t')) a"
       and IH: "s t σ. st = (σ, SubnetS s t)  P σ s t"
    from this(1) obtain s t σ where "st = (σ, SubnetS s t)"
                                and "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) S U"
      by (metis net_par_oreachable_is_subnet prod.collapse)
    note this(2)
    moreover from tr and st = (σ, SubnetS s t)
      have "((σ, SubnetS s t), a, (σ', SubnetS s' t'))  trans (opnet onp (p1  p2))" by simp
    moreover from S (fst st) (fst (σ', SubnetS s' t')) a and st = (σ, SubnetS s t)
      have "S σ σ' a" by simp
    moreover from IH and st = (σ, SubnetS s t) have "P σ s t" .
    ultimately show "P σ' s' t'" by (rule local)
  next
    fix st σ' s t
    assume "st  oreachable (opnet onp (p1  p2)) S U"
       and "U (fst st) σ'"
       and "snd st = SubnetS s t"
       and IH: "s t σ. st = (σ, SubnetS s t)  P σ s t"
    from this(1,3) obtain σ where "st = (σ, SubnetS s t)"
                              and "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) S U"
      by (metis prod.collapse)
    note this(2)
    moreover from U (fst st) σ' and st = (σ, SubnetS s t) have "U σ σ'" by simp
    moreover from IH and st = (σ, SubnetS s t) have "P σ s t" .
    ultimately show "P σ' s t" by (rule other)
  qed

lemma other_net_tree_ips_par_left:
  assumes "other U (net_tree_ips (p1  p2)) σ σ'"
      and "ξ. U ξ ξ"
    shows "other U (net_tree_ips p1) σ σ'"
  proof -
    from assms(1) obtain ineq: "inet_tree_ips (p1  p2). σ' i = σ i"
                     and outU: "j. jnet_tree_ips (p1  p2)  U (σ j) (σ' j)" ..
    show ?thesis
    proof (rule otherI)
      fix i
      assume "inet_tree_ips p1"
      hence "inet_tree_ips (p1  p2)" by simp
      with ineq show "σ' i = σ i" ..
    next
      fix j
      assume "jnet_tree_ips p1"
      show "U (σ j) (σ' j)"
      proof (cases "jnet_tree_ips p2")
        assume "jnet_tree_ips p2"
        hence "jnet_tree_ips (p1  p2)" by simp
        with ineq have "σ' j = σ j" ..
        thus "U (σ j) (σ' j)"
          by simp (rule ξ. U ξ ξ)
      next
        assume "jnet_tree_ips p2"
        with jnet_tree_ips p1 have "jnet_tree_ips (p1  p2)" by simp
        with outU show "U (σ j) (σ' j)" by simp
      qed
    qed
  qed

lemma other_net_tree_ips_par_right:
  assumes "other U (net_tree_ips (p1  p2)) σ σ'"
      and "ξ. U ξ ξ"
    shows "other U (net_tree_ips p2) σ σ'"
  proof -
    from assms(1) have "other U (net_tree_ips (p2  p1)) σ σ'"
      by (subst net_tree_ips_commute)
    thus ?thesis using ξ. U ξ ξ
      by (rule other_net_tree_ips_par_left)
  qed

lemma ostep_arrive_invariantD [elim]:
  assumes "p A (λσ _. oarrivemsg I σ, U →) P"
      and "(σ, s)  oreachable p (otherwith S IPS (oarrivemsg I)) U"
      and "((σ, s), a, (σ', s'))  trans p"
      and "oarrivemsg I σ a"
    shows "P ((σ, s), a, (σ', s'))"
  proof -
    from assms(2) have "(σ, s)  oreachable p (λσ _ a. oarrivemsg I σ a) U"
      by (rule oreachable_weakenE) auto
    thus "P ((σ, s), a, (σ', s'))"
      using assms(3-4) by (rule ostep_invariantD [OF assms(1)])
  qed

lemma opnet_sync_action_subnet_oreachable:
  assumes "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2))
                                         (λσ _. oarrivemsg I σ) (other U (net_tree_ips (p1  p2)))"
          (is "_  oreachable _ (?S (p1  p2)) (?U (p1  p2))")

      and "ξ. U ξ ξ"

      and act1: "opnet onp p1 A (λσ _. oarrivemsg I σ, other U (net_tree_ips p1) →)
                   globala (λ(σ, a, σ'). castmsg (I σ) a
                                           (a = τ  (i d. a = i:deliver(d)) 
                                                 ((inet_tree_ips p1. U (σ i) (σ' i))
                                                (i. inet_tree_ips p1  σ' i = σ i))))"

      and act2: "opnet onp p2 A (λσ _. oarrivemsg I σ, other U (net_tree_ips p2) →)
                   globala (λ(σ, a, σ'). castmsg (I σ) a
                                           (a = τ  (i d. a = i:deliver(d)) 
                                                 ((inet_tree_ips p2. U (σ i) (σ' i))
                                                (i. inet_tree_ips p2  σ' i = σ i))))"

    shows "(σ, s)  oreachable (opnet onp p1) (λσ _. oarrivemsg I σ) (other U (net_tree_ips p1))
            (σ, t)  oreachable (opnet onp p2) (λσ _. oarrivemsg I σ) (other U (net_tree_ips p2))
            net_tree_ips p1  net_tree_ips p2 = {}"
  using assms(1)
  proof (induction rule: oreachable_par_subnet_induct)
    case (init σ s t)
    hence sinit: "(σ, s)  init (opnet onp p1)"
      and tinit: "(σ, t)  init (opnet onp p2)"
      and "net_ips s  net_ips t = {}" by auto
    moreover from sinit have "net_ips s = net_tree_ips p1"
      by (rule opnet_net_ips_net_tree_ips_init)
    moreover from tinit have "net_ips t = net_tree_ips p2"
      by (rule opnet_net_ips_net_tree_ips_init)
    ultimately show ?case by (auto elim: oreachable_init)
  next
    case (other σ s t σ')
    hence "other U (net_tree_ips (p1  p2)) σ σ'"
      and IHs: "(σ, s)  oreachable (opnet onp p1) (?S p1) (?U p1)"
      and IHt: "(σ, t)  oreachable (opnet onp p2) (?S p2) (?U p2)"
      and "net_tree_ips p1  net_tree_ips p2 = {}" by auto

    have "(σ', s)  oreachable (opnet onp p1) (?S p1) (?U p1)"
    proof -
      from ?U (p1  p2) σ σ' and ξ. U ξ ξ have "?U p1 σ σ'"
        by (rule other_net_tree_ips_par_left)
      with IHs show ?thesis by - (erule(1) oreachable_other')
    qed

    moreover have "(σ', t)  oreachable (opnet onp p2) (?S p2) (?U p2)"
    proof -
      from ?U (p1  p2) σ σ' and ξ. U ξ ξ have "?U p2 σ σ'"
        by (rule other_net_tree_ips_par_right)
      with IHt show ?thesis by - (erule(1) oreachable_other')
    qed

    ultimately show ?case using ‹net_tree_ips p1  net_tree_ips p2 = {} by simp
  next
    case (local σ s t σ' s' t' a)
    hence stor: "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) (?S (p1  p2)) (?U (p1  p2))"
      and tr: "((σ, SubnetS s t), a, (σ', SubnetS s' t'))  trans (opnet onp (p1  p2))"
      and "oarrivemsg I σ a"
      and sor: "(σ, s)  oreachable (opnet onp p1) (?S p1) (?U p1)"
      and tor: "(σ, t)  oreachable (opnet onp p2) (?S p2) (?U p2)"
      and "net_tree_ips p1  net_tree_ips p2 = {}" by auto
    from tr have "((σ, SubnetS s t), a, (σ', SubnetS s' t'))
                     opnet_sos (trans (opnet onp p1)) (trans (opnet onp p2))" by simp
    hence "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)
          (σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
    proof (cases)
      fix H K m H' K'
      assume "a = (H  H')¬(K  K'):arrive(m)"
         and str: "((σ, s), H¬K:arrive(m), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), H'¬K':arrive(m), (σ', t'))  trans (opnet onp p2)"
      from this(1) and ‹oarrivemsg I σ a have "I σ m" by simp

      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from I σ m tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix R m H K
      assume str: "((σ, s), R:*cast(m), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), H¬K:arrive(m), (σ', t'))  trans (opnet onp p2)"                                    
      from sor str have "I σ m"
        by - (drule(1) ostep_invariantD [OF act1], simp_all)
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from I σ m tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix R m H K
      assume str: "((σ, s), H¬K:arrive(m), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), R:*cast(m), (σ', t'))  trans (opnet onp p2)"                                    
      from tor ttr have "I σ m"
        by - (drule(1) ostep_invariantD [OF act2], simp_all)
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from I σ m tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix i i'
      assume str: "((σ, s), connect(i, i'), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), connect(i, i'), (σ', t'))  trans (opnet onp p2)"
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix i i'
      assume str: "((σ, s), disconnect(i, i'), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), disconnect(i, i'), (σ', t'))  trans (opnet onp p2)"
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix i d
      assume "t' = t"
         and str: "((σ, s), i:deliver(d), (σ', s'))  trans (opnet onp p1)"

      from sor str have "j. jnet_tree_ips p1  σ' j = σ j"
        by - (drule(1) ostep_invariantD [OF act1], simp_all)
      moreover with ‹net_tree_ips p1  net_tree_ips p2 = {}
        have "j. jnet_tree_ips p2  σ' j = σ j" by auto
      moreover from sor str have "jnet_tree_ips p1. U (σ j) (σ' j)"
        by - (drule(1) ostep_invariantD [OF act1], simp_all)
      ultimately have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
        using tor t' = t by (clarsimp elim!: oreachable_other')
                              (metis otherI ξ. U ξ ξ)+

      moreover from sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis by (rule conjI [rotated])
    next
      fix i d
      assume "s' = s"
         and ttr: "((σ, t), i:deliver(d), (σ', t'))  trans (opnet onp p2)"

      from tor ttr have "j. jnet_tree_ips p2  σ' j = σ j"
        by - (drule(1) ostep_invariantD [OF act2], simp_all)
      moreover with ‹net_tree_ips p1  net_tree_ips p2 = {}
        have "j. jnet_tree_ips p1  σ' j = σ j" by auto
      moreover from tor ttr have "jnet_tree_ips p2. U (σ j) (σ' j)"
        by - (drule(1) ostep_invariantD [OF act2], simp_all)
      ultimately have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
        using sor s' = s by (clarsimp elim!: oreachable_other')
                              (metis otherI ξ. U ξ ξ)+

      moreover from tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      assume "t' = t"
         and str: "((σ, s), τ, (σ', s'))  trans (opnet onp p1)"

      from sor str have "j. jnet_tree_ips p1  σ' j = σ j"
        by - (drule(1) ostep_invariantD [OF act1], simp_all)
      moreover with ‹net_tree_ips p1  net_tree_ips p2 = {}
        have "j. jnet_tree_ips p2  σ' j = σ j" by auto
      moreover from sor str have "jnet_tree_ips p1. U (σ j) (σ' j)"
        by - (drule(1) ostep_invariantD [OF act1], simp_all)
      ultimately have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
        using tor t' = t by (clarsimp elim!: oreachable_other')
                              (metis otherI ξ. U ξ ξ)+

      moreover from sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis by (rule conjI [rotated])
    next
      assume "s' = s"
         and ttr: "((σ, t), τ, (σ', t'))  trans (opnet onp p2)"

      from tor ttr have "j. jnet_tree_ips p2  σ' j = σ j"
        by - (drule(1) ostep_invariantD [OF act2], simp_all)
      moreover with ‹net_tree_ips p1  net_tree_ips p2 = {}
        have "j. jnet_tree_ips p1  σ' j = σ j" by auto
      moreover from tor ttr have "jnet_tree_ips p2. U (σ j) (σ' j)"
        by - (drule(1) ostep_invariantD [OF act2], simp_all)
      ultimately have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
        using sor s' = s by (clarsimp elim!: oreachable_other')
                              (metis otherI ξ. U ξ ξ)+

      moreover from tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    qed
    with ‹net_tree_ips p1  net_tree_ips p2 = {} show ?case by simp
  qed

text ‹
  `Splitting' reachability is trivial when there are no assumptions on interleavings, but
  this is useless for showing non-trivial properties, since the interleaving steps can do
  anything at all. This lemma is too weak.
›

lemma subnet_oreachable_true_true:
  assumes "(σ, SubnetS s1 s2)  oreachable (opnet onp (p1  p2)) (λ_ _ _. True) (λ_ _. True)"
    shows "(σ, s1)  oreachable (opnet onp p1) (λ_ _ _. True) (λ_ _. True)"
          "(σ, s2)  oreachable (opnet onp p2) (λ_ _ _. True) (λ_ _. True)"
          (is "_  ?oreachable p2")
  using assms proof -
    from assms have "(σ, s1)  ?oreachable p1  (σ, s2)  ?oreachable p2"
    proof (induction rule: oreachable_par_subnet_induct)
      fix σ s1 s2
      assume "(σ, SubnetS s1 s2)  init (opnet onp (p1  p2))"
      thus "(σ, s1)  ?oreachable p1  (σ, s2)  ?oreachable p2"
        by (auto dest: oreachable_init)
    next
      case (local σ s1 s2 σ' s1' s2' a)
      hence "(σ, SubnetS s1 s2)  ?oreachable (p1  p2)"
        and sr1: "(σ, s1)  ?oreachable p1"
        and sr2: "(σ, s2)  ?oreachable p2"
        and "((σ, SubnetS s1 s2), a, (σ', SubnetS s1' s2'))  trans (opnet onp (p1  p2))" by auto
      from this(4)
        have "((σ, SubnetS s1 s2), a, (σ', SubnetS s1' s2'))
                 opnet_sos (trans (opnet onp p1)) (trans (opnet onp p2))" by simp
      thus "(σ', s1')  ?oreachable p1  (σ', s2')  ?oreachable p2"
      proof cases
        fix R m H K
        assume "a = R:*cast(m)"
           and tr1: "((σ, s1), R:*cast(m), (σ', s1'))  trans (opnet onp p1)"
           and tr2: "((σ, s2), H¬K:arrive(m), (σ', s2'))  trans (opnet onp p2)"
        from sr1 and tr1 and TrueI have "(σ', s1')  ?oreachable p1"
          by (rule oreachable_local')
        moreover from sr2 and tr2 and TrueI have "(σ', s2')  ?oreachable p2"
          by (rule oreachable_local')
        ultimately show ?thesis ..
      next
        assume "a = τ"
           and "s2' = s2"
           and tr1: "((σ, s1), τ, (σ', s1'))  trans (opnet onp p1)"
        from sr2 and this(2) have "(σ', s2')  ?oreachable p2" by auto
        moreover have "(λ_ _. True) σ σ'" by (rule TrueI)
        ultimately have "(σ', s2')  ?oreachable p2"
          by (rule oreachable_other')
        moreover from sr1 and tr1 and TrueI have "(σ', s1')  ?oreachable p1"
          by (rule oreachable_local')
      qed (insert sr1 sr2, simp_all, (metis (no_types) oreachable_local'
                                                       oreachable_other')+)
    qed auto
    thus "(σ, s1)  ?oreachable p1"
         "(σ, s2)  ?oreachable p2" by auto
  qed

text ‹
  It may also be tempting to try splitting from the assumption
  @{term "(σ, SubnetS s1 s2)  oreachable (opnet onp (p1  p2)) (λ_ _ _. True) (λ_ _. False)"},
  where the environment step would be trivially true (since the assumption is false), but the
  lemma cannot be shown when only one side acts, since it must guarantee the assumption for
  the other side.
›

lemma lift_opnet_sync_action:
  assumes "ξ. U ξ ξ"
      and act1: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, _). castmsg (I σ) a)"
      and act2: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, σ'). (a  τ  (d. a  i:deliver(d))  S (σ i) (σ' i)))"
      and act3: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, σ'). (a = τ  (d. a = i:deliver(d))  U (σ i) (σ' i)))"
  shows "opnet onp p A (λσ _. oarrivemsg I σ, other U (net_tree_ips p) →)
                       globala (λ(σ, a, σ'). castmsg (I σ) a
                                               (a  τ  (i d. a  i:deliver(d)) 
                                                     (inet_tree_ips p. S (σ i) (σ' i)))
                                               (a = τ  (i d. a = i:deliver(d)) 
                                                     ((inet_tree_ips p. U (σ i) (σ' i))
                                                    (i. inet_tree_ips p  σ' i = σ i))))"
    (is "opnet onp p A (?I, ?U p →) ?inv (net_tree_ips p)")
  proof (induction p)
    fix i R
    show "opnet onp i; R A (?I, ?U i; R →) ?inv (net_tree_ips i; R)"
    proof (rule ostep_invariantI, simp only: opnet.simps net_tree_ips.simps)
      fix σ s a σ' s'
      assume sor: "(σ, s)  oreachable (i : onp i : Ro) (λσ _. oarrivemsg I σ) (other U {i})"
         and str: "((σ, s), a, (σ', s'))  trans (i : onp i : Ro)"
         and oam: "oarrivemsg I σ a"             
      hence "castmsg (I σ) a"
        by - (drule(2) ostep_invariantD [OF act1], simp)
      moreover from sor str oam have "a  τ  (i d. a  i:deliver(d))  S (σ i) (σ' i)"
        by - (drule(2) ostep_invariantD [OF act2], simp)
      moreover have "a = τ  (i d. a = i:deliver(d))  U (σ i) (σ' i)"
      proof -
        from sor str oam have "a = τ  (d. a = i:deliver(d))  U (σ i) (σ' i)"
          by - (drule(2) ostep_invariantD [OF act3], simp)
        moreover from sor str oam have "j. ji  (d. a  j:deliver(d))"
          by - (drule(2) ostep_invariantD [OF node_local_deliver], simp)
        ultimately show ?thesis
          by clarsimp metis
      qed
      moreover from sor str oam have "j. ji  (d. a  j:deliver(d))"
        by - (drule(2) ostep_invariantD [OF node_local_deliver], simp)
      moreover from sor str oam have "a = τ  (i d. a = i:deliver(d))  (j. ji  σ' j = σ j)"
        by - (drule(2) ostep_invariantD [OF node_tau_deliver_unchanged], simp)
      ultimately show "?inv {i} ((σ, s), a, (σ', s'))" by simp
    qed
  next
    fix p1 p2
    assume inv1: "opnet onp p1 A (?I, ?U p1 →) ?inv (net_tree_ips p1)"
       and inv2: "opnet onp p2 A (?I, ?U p2 →) ?inv (net_tree_ips p2)"
    show "opnet onp (p1  p2) A (?I, ?U (p1  p2) →) ?inv (net_tree_ips (p1  p2))"
    proof (rule ostep_invariantI)
      fix σ st a σ' st'
      assume "(σ, st)  oreachable (opnet onp (p1  p2)) ?I (?U (p1  p2))"
         and "((σ, st), a, (σ', st'))  trans (opnet onp (p1  p2))"
         and "oarrivemsg I σ a"
      from this(1) obtain s t
        where "st = SubnetS s t"
          and *: "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) ?I (?U (p1  p2))"
        by - (frule net_par_oreachable_is_subnet, metis)

      from this(2) and inv1 and inv2
        obtain sor: "(σ, s)  oreachable (opnet onp p1) ?I (?U p1)"
           and tor: "(σ, t)  oreachable (opnet onp p2) ?I (?U p2)"
           and "net_tree_ips p1  net_tree_ips p2 = {}"
          by - (drule opnet_sync_action_subnet_oreachable [OF _ ξ. U ξ ξ], auto)

      from * and ((σ, st), a, (σ', st'))  trans (opnet onp (p1  p2)) and st = SubnetS s t
        obtain s' t' where "st' = SubnetS s' t'"
                       and "((σ, SubnetS s t), a, (σ', SubnetS s' t'))
                               opnet_sos (trans (opnet onp p1)) (trans (opnet onp p2))"
          by clarsimp (frule opartial_net_preserves_subnets, metis)

      from this(2)
        have"castmsg (I σ) a
              (a  τ  (i d. a  i:deliver(d))  (inet_tree_ips (p1  p2). S (σ i) (σ' i)))
              (a = τ  (i d. a = i:deliver(d))  (inet_tree_ips (p1  p2). U (σ i) (σ' i))
                                                   (i. i  net_tree_ips (p1  p2)  σ' i = σ i))"
      proof cases
        fix R m H K
        assume "a = R:*cast(m)" 
           and str: "((σ, s), R:*cast(m), (σ', s'))  trans (opnet onp p1)"
           and ttr: "((σ, t), H¬K:arrive(m), (σ', t'))  trans (opnet onp p2)"
        from sor and str have "I σ m  (inet_tree_ips p1. S (σ i) (σ' i))"
          by (auto dest: ostep_invariantD [OF inv1])
        moreover with tor and ttr have "inet_tree_ips p2. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv2])
        ultimately show ?thesis
          using a = R:*cast(m) by auto
      next
        fix R m H K
        assume "a = R:*cast(m)" 
           and str: "((σ, s), H¬K:arrive(m), (σ', s'))  trans (opnet onp p1)"
           and ttr: "((σ, t), R:*cast(m), (σ', t'))  trans (opnet onp p2)"
        from tor and ttr have "I σ m  (inet_tree_ips p2. S (σ i) (σ' i))"
          by (auto dest: ostep_invariantD [OF inv2])
        moreover with sor and str have "inet_tree_ips p1. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv1])
        ultimately show ?thesis
          using a = R:*cast(m) by auto
      next
        fix H K m H' K'
        assume "a = (H  H')¬(K  K'):arrive(m)"
           and str: "((σ, s), H¬K:arrive(m), (σ', s'))  trans (opnet onp p1)"
           and ttr: "((σ, t), H'¬K':arrive(m), (σ', t'))  trans (opnet onp p2)"
        from this(1) and ‹oarrivemsg I σ a have "I σ m" by simp
        with sor and str have "inet_tree_ips p1. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv1])
        moreover from tor and ttr and I σ m have "inet_tree_ips p2. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv2])
        ultimately show ?thesis
          using a = (H  H')¬(K  K'):arrive(m) by auto
      next
        fix i d
        assume "a = i:deliver(d)"
           and str: "((σ, s), i:deliver(d), (σ', s'))  trans (opnet onp p1)"
        with sor have "((inet_tree_ips p1. U (σ i) (σ' i))
                        (i. inet_tree_ips p1  σ' i = σ i))"
          by (auto dest!: ostep_invariantD [OF inv1])
        with a = i:deliver(d) and ξ. U ξ ξ show ?thesis
          by auto
      next
        fix i d
        assume "a = i:deliver(d)"
           and ttr: "((σ, t), i:deliver(d), (σ', t'))  trans (opnet onp p2)"
        with tor have "((inet_tree_ips p2. U (σ i) (σ' i))
                        (i. inet_tree_ips p2  σ' i = σ i))"
          by (auto dest!: ostep_invariantD [OF inv2])
        with a = i:deliver(d) and ξ. U ξ ξ show ?thesis
          by auto
      next
        assume "a = τ"
           and str: "((σ, s), τ, (σ', s'))  trans (opnet onp p1)"
        with sor have "((inet_tree_ips p1. U (σ i) (σ' i))
                        (i. inet_tree_ips p1  σ' i = σ i))"
          by (auto dest!: ostep_invariantD [OF inv1])
        with a = τ and ξ. U ξ ξ show ?thesis
          by auto
      next
        assume "a = τ"
           and ttr: "((σ, t), τ, (σ', t'))  trans (opnet onp p2)"
        with tor have "((inet_tree_ips p2. U (σ i) (σ' i))
                        (i. inet_tree_ips p2  σ' i = σ i))"
          by (auto dest!: ostep_invariantD [OF inv2])
        with a = τ and ξ. U ξ ξ show ?thesis
          by auto
      next
        fix i i'
        assume "a = connect(i, i')"
           and str: "((σ, s), connect(i, i'), (σ', s'))  trans (opnet onp p1)"
           and ttr: "((σ, t), connect(i, i'), (σ', t'))  trans (opnet onp p2)"
        from sor and str have "inet_tree_ips p1. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv1])
        moreover from tor and ttr have "inet_tree_ips p2. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv2])
        ultimately show ?thesis
          using a = connect(i, i') by auto
      next
        fix i i'
        assume "a = disconnect(i, i')"
           and str: "((σ, s), disconnect(i, i'), (σ', s'))  trans (opnet onp p1)"
           and ttr: "((σ, t), disconnect(i, i'), (σ', t'))  trans (opnet onp p2)"
        from sor and str have "inet_tree_ips p1. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv1])
        moreover from tor and ttr have "inet_tree_ips p2. S (σ i) (σ' i)"
          by (auto dest: ostep_invariantD [OF inv2])
        ultimately show ?thesis
          using a = disconnect(i, i') by auto
      qed
      thus "?inv (net_tree_ips (p1  p2)) ((σ, st), a, (σ', st'))" by simp
    qed
  qed

theorem subnet_oreachable:
  assumes "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2))
                                (otherwith S (net_tree_ips (p1  p2)) (oarrivemsg I))
                                (other U (net_tree_ips (p1  p2)))"
          (is "_  oreachable _ (?S (p1  p2)) (?U (p1  p2))")

      and "ξ. S ξ ξ"
      and "ξ. U ξ ξ"

      and node1: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, _). castmsg (I σ) a)"
      and node2: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, σ'). (a  τ  (d. a  i:deliver(d))  S (σ i) (σ' i)))"
      and node3: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, σ'). (a = τ  (d. a = i:deliver(d))  U (σ i) (σ' i)))"

    shows "(σ, s)  oreachable (opnet onp p1)
                               (otherwith S (net_tree_ips p1) (oarrivemsg I))
                               (other U (net_tree_ips p1))
            (σ, t)  oreachable (opnet onp p2)
                                  (otherwith S (net_tree_ips p2) (oarrivemsg I))
                                  (other U (net_tree_ips p2))
            net_tree_ips p1  net_tree_ips p2 = {}"
  using assms(1) proof (induction rule: oreachable_par_subnet_induct)
    case (init σ s t)
    hence sinit: "(σ, s)  init (opnet onp p1)"
      and tinit: "(σ, t)  init (opnet onp p2)"
      and "net_ips s  net_ips t = {}" by auto
    moreover from sinit have "net_ips s = net_tree_ips p1"
      by (rule opnet_net_ips_net_tree_ips_init)
    moreover from tinit have "net_ips t = net_tree_ips p2"
      by (rule opnet_net_ips_net_tree_ips_init)
    ultimately show ?case by (auto elim: oreachable_init)
  next
    case (other σ s t σ')
    hence "other U (net_tree_ips (p1  p2)) σ σ'"
      and IHs: "(σ, s)  oreachable (opnet onp p1) (?S p1) (?U p1)"
      and IHt: "(σ, t)  oreachable (opnet onp p2) (?S p2) (?U p2)"
      and "net_tree_ips p1  net_tree_ips p2 = {}" by auto

    have "(σ', s)  oreachable (opnet onp p1) (?S p1) (?U p1)"
    proof -
      from ?U (p1  p2) σ σ' and ξ. U ξ ξ have "?U p1 σ σ'"
        by (rule other_net_tree_ips_par_left)
      with IHs show ?thesis by - (erule(1) oreachable_other')
    qed

    moreover have "(σ', t)  oreachable (opnet onp p2) (?S p2) (?U p2)"
    proof -
      from ?U (p1  p2) σ σ' and ξ. U ξ ξ have "?U p2 σ σ'"
        by (rule other_net_tree_ips_par_right)
      with IHt show ?thesis by - (erule(1) oreachable_other')
    qed

    ultimately show ?case using ‹net_tree_ips p1  net_tree_ips p2 = {} by simp
  next
    case (local σ s t σ' s' t' a)
    hence stor: "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2)) (?S (p1  p2)) (?U (p1  p2))"
      and tr: "((σ, SubnetS s t), a, (σ', SubnetS s' t'))  trans (opnet onp (p1  p2))"
      and "?S (p1  p2) σ σ' a"
      and sor: "(σ, s)  oreachable (opnet onp p1) (?S p1) (?U p1)"
      and tor: "(σ, t)  oreachable (opnet onp p2) (?S p2) (?U p2)"
      and "net_tree_ips p1  net_tree_ips p2 = {}" by auto

    have act: "p. opnet onp p A (λσ _. oarrivemsg I σ, other U (net_tree_ips p) →)
                 globala (λ(σ, a, σ'). castmsg (I σ) a
                                         (a  τ  (i d. a  i:deliver(d)) 
                                               (inet_tree_ips p. S (σ i) (σ' i)))
                                         (a = τ  (i d. a = i:deliver(d)) 
                                               ((inet_tree_ips p. U (σ i) (σ' i))
                                              (i. inet_tree_ips p  σ' i = σ i))))"
      by (rule lift_opnet_sync_action [OF assms(3-6)])

    from ?S (p1  p2) σ σ' a have "j. j  net_tree_ips (p1  p2)  S (σ j) (σ' j)"
                                and "oarrivemsg I σ a"
      by (auto elim!: otherwithE)
    from tr have "((σ, SubnetS s t), a, (σ', SubnetS s' t'))
                     opnet_sos (trans (opnet onp p1)) (trans (opnet onp p2))" by simp
    hence "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)
          (σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
    proof (cases)
      fix H K m H' K'
      assume "a = (H  H')¬(K  K'):arrive(m)"
         and str: "((σ, s), H¬K:arrive(m), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), H'¬K':arrive(m), (σ', t'))  trans (opnet onp p2)"
      from this(1) and ?S (p1  p2) σ σ' a have "I σ m" by auto

      with sor str have "inet_tree_ips p1. S (σ i) (σ' i)"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      moreover from I σ m tor ttr have "inet_tree_ips p2. S (σ i) (σ' i)"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      ultimately have "i. S (σ i) (σ' i)"
        using j. j  net_tree_ips (p1  p2)  S (σ j) (σ' j) by auto

      with I σ m sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from i. S (σ i) (σ' i) I σ m tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix R m H K
      assume str: "((σ, s), R:*cast(m), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), H¬K:arrive(m), (σ', t'))  trans (opnet onp p2)"                                    
      from sor str have "I σ m"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      with sor str tor ttr have "i. S (σ i) (σ' i)"
        using j. j  net_tree_ips (p1  p2)  S (σ j) (σ' j)
        by (fastforce dest!: ostep_arrive_invariantD [OF act] ostep_arrive_invariantD [OF act])
      with I σ m sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from i. S (σ i) (σ' i) I σ m tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix R m H K
      assume str: "((σ, s), H¬K:arrive(m), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), R:*cast(m), (σ', t'))  trans (opnet onp p2)"                                    
      from tor ttr have "I σ m"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      with sor str tor ttr have "i. S (σ i) (σ' i)"
        using j. j  net_tree_ips (p1  p2)  S (σ j) (σ' j)
        by (fastforce dest!: ostep_arrive_invariantD [OF act] ostep_arrive_invariantD [OF act])
      with I σ m sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from i. S (σ i) (σ' i) I σ m tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix i i'
      assume str: "((σ, s), connect(i, i'), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), connect(i, i'), (σ', t'))  trans (opnet onp p2)"
      with sor tor have "i. S (σ i) (σ' i)"
        using j. j  net_tree_ips (p1  p2)  S (σ j) (σ' j)
        by (fastforce dest!: ostep_arrive_invariantD [OF act] ostep_arrive_invariantD [OF act])
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from i. S (σ i) (σ' i) tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix i i'
      assume str: "((σ, s), disconnect(i, i'), (σ', s'))  trans (opnet onp p1)"
         and ttr: "((σ, t), disconnect(i, i'), (σ', t'))  trans (opnet onp p2)"
      with sor tor have "i. S (σ i) (σ' i)"
        using j. j  net_tree_ips (p1  p2)  S (σ j) (σ' j)
        by (fastforce dest!: ostep_arrive_invariantD [OF act] ostep_arrive_invariantD [OF act])
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)
      moreover from i. S (σ i) (σ' i) tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)
      ultimately show ?thesis ..
    next
      fix i d
      assume "t' = t"
         and str: "((σ, s), i:deliver(d), (σ', s'))  trans (opnet onp p1)"
      from sor str have "j. jnet_tree_ips p1  σ' j = σ j"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      hence "j. jnet_tree_ips p1  S (σ j) (σ' j)"
         by (auto intro: ξ. S ξ ξ)
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)

      moreover have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
      proof -
        from j. jnet_tree_ips p1  σ' j = σ j and ‹net_tree_ips p1  net_tree_ips p2 = {}
          have "j. jnet_tree_ips p2  σ' j = σ j" by auto
        moreover from sor str have "jnet_tree_ips p1. U (σ j) (σ' j)"
          by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
        ultimately show ?thesis
          using tor t' = t j. j  net_tree_ips p1  σ' j = σ j
          by (clarsimp elim!: oreachable_other')
             (metis otherI ξ. U ξ ξ)+
      qed
      ultimately show ?thesis ..
    next
      fix i d
      assume "s' = s"
         and ttr: "((σ, t), i:deliver(d), (σ', t'))  trans (opnet onp p2)"
      from tor ttr have "j. jnet_tree_ips p2  σ' j = σ j"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      hence "j. jnet_tree_ips p2  S (σ j) (σ' j)"
         by (auto intro: ξ. S ξ ξ)
      with tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)

      moreover have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
      proof -
        from j. jnet_tree_ips p2  σ' j = σ j and ‹net_tree_ips p1  net_tree_ips p2 = {}
          have "j. jnet_tree_ips p1  σ' j = σ j" by auto
        moreover from tor ttr have "jnet_tree_ips p2. U (σ j) (σ' j)"
          by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
        ultimately show ?thesis
          using sor s' = s j. j  net_tree_ips p2  σ' j = σ j
          by (clarsimp elim!: oreachable_other')
             (metis otherI ξ. U ξ ξ)+
      qed
      ultimately show ?thesis by - (rule conjI)
    next
      assume "s' = s"
         and ttr: "((σ, t), τ, (σ', t'))  trans (opnet onp p2)"
      from tor ttr have "j. jnet_tree_ips p2  σ' j = σ j"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      hence "j. jnet_tree_ips p2  S (σ j) (σ' j)"
         by (auto intro: ξ. S ξ ξ)
      with tor ttr
        have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
          by - (erule(1) oreachable_local, auto)

      moreover have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
      proof -
        from j. jnet_tree_ips p2  σ' j = σ j and ‹net_tree_ips p1  net_tree_ips p2 = {}
          have "j. jnet_tree_ips p1  σ' j = σ j" by auto
        moreover from tor ttr have "jnet_tree_ips p2. U (σ j) (σ' j)"
          by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
        ultimately show ?thesis
          using sor s' = s j. j  net_tree_ips p2  σ' j = σ j
          by (clarsimp elim!: oreachable_other')
             (metis otherI ξ. U ξ ξ)+
      qed
      ultimately show ?thesis by - (rule conjI)
    next
      assume "t' = t"
         and str: "((σ, s), τ, (σ', s'))  trans (opnet onp p1)"
      from sor str have "j. jnet_tree_ips p1  σ' j = σ j"
        by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
      hence "j. jnet_tree_ips p1  S (σ j) (σ' j)"
         by (auto intro: ξ. S ξ ξ)
      with sor str
        have "(σ', s')  oreachable (opnet onp p1) (?S p1) (?U p1)"
          by - (erule(1) oreachable_local, auto)

      moreover have "(σ', t')  oreachable (opnet onp p2) (?S p2) (?U p2)"
      proof -
        from j. jnet_tree_ips p1  σ' j = σ j and ‹net_tree_ips p1  net_tree_ips p2 = {}
          have "j. jnet_tree_ips p2  σ' j = σ j" by auto
        moreover from sor str have "jnet_tree_ips p1. U (σ j) (σ' j)"
          by - (drule(1) ostep_arrive_invariantD [OF act], simp_all)
        ultimately show ?thesis
          using tor t' = t j. j  net_tree_ips p1  σ' j = σ j
          by (clarsimp elim!: oreachable_other')
             (metis otherI ξ. U ξ ξ)+
      qed
      ultimately show ?thesis ..
    qed
    with ‹net_tree_ips p1  net_tree_ips p2 = {} show ?case by simp
  qed

lemmas subnet_oreachable1 [dest] = subnet_oreachable [THEN conjunct1, rotated 1]
lemmas subnet_oreachable2 [dest] = subnet_oreachable [THEN conjunct2, THEN conjunct1, rotated 1]
lemmas subnet_oreachable_disjoint [dest] = subnet_oreachable
                                                    [THEN conjunct2, THEN conjunct2, rotated 1]

corollary pnet_lift:
  assumes "ii Ri. ii : onp ii : Rio
               (otherwith S {ii} (oarrivemsg I), other U {ii} →) global (P ii)"

      and "ξ. S ξ ξ"
      and "ξ. U ξ ξ"

      and node1: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, _). castmsg (I σ) a)"
      and node2: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, σ'). (a  τ  (d. a  i:deliver(d))  S (σ i) (σ' i)))"
      and node3: "i R. i : onp i : Ro A (λσ _. oarrivemsg I σ, other U {i} →)
                      globala (λ(σ, a, σ'). (a = τ  (d. a = i:deliver(d))  U (σ i) (σ' i)))"

    shows "opnet onp p  (otherwith S (net_tree_ips p) (oarrivemsg I),
                       other U (net_tree_ips p) →) global (λσ. inet_tree_ips p. P i σ)"
      (is "_  (?owS p, ?U p →) _")
  proof (induction p)
    fix ii Ri
    from assms(1) show "opnet onp ii; Ri  (?owS ii; Ri, ?U ii; Ri →)
                                         global (λσ. inet_tree_ips ii; Ri. P i σ)" by auto
  next
    fix p1 p2
    assume ih1: "opnet onp p1  (?owS p1, ?U p1 →) global (λσ. inet_tree_ips p1. P i σ)"
       and ih2: "opnet onp p2  (?owS p2, ?U p2 →) global (λσ. inet_tree_ips p2. P i σ)"
    show "opnet onp (p1  p2)  (?owS (p1  p2), ?U (p1  p2) →)
                             global (λσ. inet_tree_ips (p1  p2). P i σ)"
    unfolding oinvariant_def
    proof
      fix pq
      assume "pq  oreachable (opnet onp (p1  p2)) (?owS (p1  p2)) (?U (p1  p2))"
      moreover then obtain σ s t where "pq = (σ, SubnetS s t)"
        by (metis net_par_oreachable_is_subnet surjective_pairing)
      ultimately have "(σ, SubnetS s t)  oreachable (opnet onp (p1  p2))
                                               (?owS (p1  p2)) (?U (p1  p2))" by simp
      then obtain sor: "(σ, s)  oreachable (opnet onp p1) (?owS p1) (?U p1)"
              and tor: "(σ, t)  oreachable (opnet onp p2) (?owS p2) (?U p2)"
        by - (drule subnet_oreachable [OF _ _ _ node1 node2 node3], auto intro: assms(2-3))
      from sor have "inet_tree_ips p1. P i σ"
        by (auto dest: oinvariantD [OF ih1])
      moreover from tor have "inet_tree_ips p2. P i σ"
        by (auto dest: oinvariantD [OF ih2])
      ultimately have "inet_tree_ips (p1  p2). P i σ" by auto
      with pq = (σ, SubnetS s t) show "global (λσ. inet_tree_ips (p1  p2). P i σ) pq" by simp
    qed
  qed

end

Theory OClosed_Lifting

(*  Title:       OClosed_Lifting.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lifting rules for (open) closed networks"

theory OClosed_Lifting
imports OPnet_Lifting
begin

lemma trans_fst_oclosed_fst1 [dest]:
  "(s, connect(i, i'), s')  ocnet_sos (trans p)  (s, connect(i, i'), s')  trans p"
  by (metis prod.exhaust oconnect_completeTE)

lemma trans_fst_oclosed_fst2 [dest]:
  "(s, disconnect(i, i'), s')  ocnet_sos (trans p)  (s, disconnect(i, i'), s')  trans p"
  by (metis prod.exhaust odisconnect_completeTE)

lemma trans_fst_oclosed_fst3 [dest]:
  "(s, i:deliver(d), s')  ocnet_sos (trans p)       (s, i:deliver(d), s')  trans p"
  by (metis prod.exhaust odeliver_completeTE)

lemma oclosed_oreachable_inclosed:
  assumes "(σ, ζ)  oreachable (oclosed (opnet np p)) (λ_ _ _. True) U"
    shows "(σ, ζ)  oreachable (opnet np p) (otherwith ((=)) (net_tree_ips p) inoclosed) U"
    (is "_  oreachable _ ?owS _")
  using assms proof (induction rule: oreachable_pair_induct)
    fix σ ζ
    assume "(σ, ζ)  init (oclosed (opnet np p))"
    hence "(σ, ζ)  init (opnet np p)" by simp
    thus "(σ, ζ)  oreachable (opnet np p) ?owS U" ..
  next
    fix σ ζ σ'
    assume "(σ, ζ)  oreachable (opnet np p) ?owS U"
       and "U σ σ'"
    thus "(σ', ζ)  oreachable (opnet np p) ?owS U"
      by - (rule oreachable_other')
  next
    fix σ ζ σ' ζ' a
    assume zor: "(σ, ζ)  oreachable (opnet np p) ?owS U"
       and ztr: "((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet np p))"
    from this(1) have [simp]: "net_ips ζ = net_tree_ips p"
      by (rule opnet_net_ips_net_tree_ips)
    from ztr have "((σ, ζ), a, (σ', ζ'))  ocnet_sos (trans (opnet np p))" by simp
    thus "(σ', ζ')  oreachable (opnet np p) ?owS U"
    proof cases
      fix i K d di
      assume "a = i:newpkt(d, di)"
         and tr: "((σ, ζ), {i}¬K:arrive(msg_class.newpkt (d, di)), (σ', ζ'))  trans (opnet np p)"
         and "j. j  net_ips ζ  σ' j = σ j"
      from this(3) have "j. j  net_tree_ips p  σ' j = σ j"
        using ‹net_ips ζ = net_tree_ips p by auto
      hence "otherwith ((=)) (net_tree_ips p) inoclosed σ σ' ({i}¬K:arrive(msg_class.newpkt (d, di)))"
        by auto
      with zor tr show ?thesis
        by - (rule oreachable_local')
    next
      assume "a = τ"
         and tr: "((σ, ζ), τ, (σ', ζ'))  trans (opnet np p)"
         and "j. j  net_ips ζ  σ' j = σ j"
      from this(3) have "j. j  net_tree_ips p  σ' j = σ j"
        using ‹net_ips ζ = net_tree_ips p by auto
      hence "otherwith ((=)) (net_tree_ips p) inoclosed σ σ' τ"
        by auto
      with zor tr show ?thesis by - (rule oreachable_local')
    qed (insert ‹net_ips ζ = net_tree_ips p,
         auto elim!: oreachable_local' [OF zor])
  qed

lemma oclosed_oreachable_oreachable [elim]:
  assumes "(σ, ζ)  oreachable (oclosed (opnet onp p)) (λ_ _ _. True) U"
    shows "(σ, ζ)  oreachable (opnet onp p) (λ_ _ _. True) U"
  using assms by (rule oclosed_oreachable_inclosed [THEN oreachable_weakenE]) simp

lemma inclosed_closed [intro]:
  assumes cinv: "opnet np p  (otherwith ((=)) (net_tree_ips p) inoclosed, U →) P"
    shows "oclosed (opnet np p)  (λ_ _ _. True, U →) P"
  using assms unfolding oinvariant_def
  by (clarsimp dest!: oclosed_oreachable_inclosed)

end

Theory AWN_Invariants

(*  Title:       AWN_Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Generic invariants on sequential AWN processes"

theory AWN_Invariants
imports Invariants AWN_SOS AWN_Labels
begin

subsection "Invariants via labelled control terms"

text ‹
  Used to state that the initial control-state of an automaton appears within a process
  specification Γ›, meaning that its transitions, and those of its subterms, are
  subsumed by those of Γ›.
›

definition
  control_within :: "('s, 'm, 'p, 'l) seqp_env  ('z × ('s, 'm, 'p, 'l) seqp) set  bool"
where
  "control_within Γ σ  (ξ, p)σ. pn. p  subterms (Γ pn)"

lemma control_withinI [intro]:
  assumes "p. p  Range σ  pn. p  subterms (Γ pn)"
    shows "control_within Γ σ"
  using assms unfolding control_within_def by auto

lemma control_withinD [dest]:
  assumes "control_within Γ σ"
      and "(ξ, p)  σ"
    shows "pn. p  subterms (Γ pn)"
  using assms unfolding control_within_def by blast

lemma control_within_topI [intro]:
  assumes "p. p  Range σ  pn. p = Γ pn"
    shows "control_within Γ σ"
  using assms unfolding control_within_def
  by clarsimp (metis Range.RangeI subterms_refl)

lemma seqp_sos_subterms:
  assumes "wellformed Γ"
      and "pn. p  subterms (Γ pn)"
      and "((ξ, p), a, (ξ', p'))  seqp_sos Γ"
    shows "pn. p'  subterms (Γ pn)"
  using assms
  proof (induct p)
    fix p1 p2
    assume IH1: "pn. p1  subterms (Γ pn) 
                      ((ξ, p1), a, (ξ', p'))  seqp_sos Γ 
                      pn. p'  subterms (Γ pn)"
       and IH2: "pn. p2  subterms (Γ pn) 
                      ((ξ, p2), a, (ξ', p'))  seqp_sos Γ 
                      pn. p'  subterms (Γ pn)"
       and "pn. p1  p2  subterms (Γ pn)"
       and "((ξ, p1  p2), a, (ξ', p'))  seqp_sos Γ"
    from pn. p1  p2  subterms (Γ pn) obtain pn
                                            where "p1  subterms (Γ pn)"
                                              and "p2  subterms (Γ pn)" by auto
    from ((ξ, p1  p2), a, (ξ', p'))  seqp_sos Γ
      have "((ξ, p1), a, (ξ', p'))  seqp_sos Γ
             ((ξ, p2), a, (ξ', p'))  seqp_sos Γ" by auto
    thus "pn. p'  subterms (Γ pn)"
    proof
      assume "((ξ, p1), a, (ξ', p'))  seqp_sos Γ"
      with p1  subterms (Γ pn) show ?thesis by (auto intro: IH1)
    next
      assume "((ξ, p2), a, (ξ', p'))  seqp_sos Γ"
      with p2  subterms (Γ pn) show ?thesis by (auto intro: IH2)
    qed
  qed auto

lemma reachable_subterms:
  assumes "wellformed Γ"
      and "control_within Γ (init A)"
      and "trans A = seqp_sos Γ"
      and "(ξ, p)  reachable A I"
    shows "pn. p  subterms (Γ pn)"
  using assms(4)
  proof (induct rule: reachable_pair_induct)
    fix ξ p
    assume "(ξ, p)  init A"
    with ‹control_within Γ (init A) show "pn. p  subterms (Γ pn)" ..
  next
    fix ξ p a ξ' p'
    assume "(ξ, p)  reachable A I"
       and "pn. p  subterms (Γ pn)"
       and *: "((ξ, p), a, (ξ', p'))  trans A"
       and "I a"
    moreover from * and assms(3) have "((ξ, p), a, (ξ', p'))  seqp_sos Γ" by simp
    ultimately show "pn. p'  subterms (Γ pn)"
    using ‹wellformed Γ
      by (auto elim: seqp_sos_subterms)
  qed

definition
  onl :: "('s, 'm, 'p, 'l) seqp_env
            ('z × 'l  bool)
            'z × ('s, 'm, 'p, 'l) seqp
            bool"
where
  "onl Γ P  (λ(ξ, p). llabels Γ p. P (ξ, l))"

lemma onlI [intro]:
  assumes "l. llabels Γ p  P (ξ, l)"
    shows "onl Γ P (ξ, p)"
  using assms unfolding onl_def by simp

lemmas onlI' [intro] = onlI [simplified atomize_ball]

lemma onlD [dest]:
  assumes "onl Γ P (ξ, p)"
    shows "llabels Γ p. P (ξ, l)"
  using assms unfolding onl_def by simp

lemma onl_invariantI [intro]:
  assumes init: "ξ p l.  (ξ, p)  init A; l  labels Γ p   P (ξ, l)"
      and step: "ξ p a ξ' p' l'.
                    (ξ, p)  reachable A I;
                     llabels Γ p. P (ξ, l);
                     ((ξ, p), a, (ξ', p'))  trans A;
                     l'  labels Γ p';
                     I a   P (ξ', l')"
    shows "A  (I →) onl Γ P"
  proof (rule invariant_pairI)
    fix ξ p
    assume "(ξ, p)  init A"
    hence "llabels Γ p. P (ξ, l)" using init by simp
    thus "onl Γ P (ξ, p)" ..
  next
    fix ξ p a ξ' p'
    assume rp: "(ξ, p)  reachable A I"
       and "onl Γ P (ξ, p)"
       and tr: "((ξ, p), a, (ξ', p'))  trans A"
       and "I a"
    from ‹onl Γ P (ξ, p) have "llabels Γ p. P (ξ, l)" ..
    with rp tr I a have "l'labels Γ p'. P (ξ', l')" by (auto elim: step)
    thus "onl Γ P (ξ', p')" ..
  qed

lemma onl_invariantD [dest]:
  assumes "A  (I →) onl Γ P"
      and "(ξ, p)  reachable A I"
      and "l  labels Γ p"
    shows "P (ξ, l)"
  using assms unfolding onl_def by auto

lemma onl_invariant_initD [dest]:
  assumes invP: "A  (I →) onl Γ P"
      and init: "(ξ, p)  init A"
      and pnl:  "l  labels Γ p"
    shows "P (ξ, l)"
  proof -
    from init have "(ξ, p)  reachable A I" ..
    with invP show ?thesis using pnl ..
  qed

lemma onl_invariant_sterms:
  assumes wf: "wellformed Γ"
      and il: "A  (I →) onl Γ P"
      and rp: "(ξ, p)  reachable A I"
      and "p'sterms Γ p"
      and "llabels Γ p'"
    shows "P (ξ, l)"
  proof -
    from wf p'sterms Γ p llabels Γ p' have "llabels Γ p"
      by (rule labels_sterms_labels)
    with il rp show "P (ξ, l)" ..
  qed

lemma onl_invariant_sterms_weaken:
  assumes wf: "wellformed Γ"
      and il: "A  (I →) onl Γ P"
      and rp: "(ξ, p)  reachable A I'"
      and "p'sterms Γ p"
      and "llabels Γ p'"
      and weaken: "a. I' a  I a"
    shows "P (ξ, l)"
  proof -
    from (ξ, p)  reachable A I' have "(ξ, p)  reachable A I"
      by (rule reachable_weakenE)
         (erule weaken)
    with assms(1-2) show ?thesis using assms(4-5) by (rule onl_invariant_sterms)
  qed

lemma onl_invariant_sterms_TT:
  assumes wf: "wellformed Γ"
      and il: "A  onl Γ P"
      and rp: "(ξ, p)  reachable A I"
      and "p'sterms Γ p"
      and "llabels Γ p'"
    shows "P (ξ, l)"
  using assms by (rule onl_invariant_sterms_weaken) simp

lemma trans_from_sterms:
  assumes "((ξ, p), a, (ξ', q))  seqp_sos Γ"
      and "wellformed Γ"
    shows "p'sterms Γ p. ((ξ, p'), a, (ξ', q))  seqp_sos Γ"
  using assms by (induction p rule: sterms_pinduct [OF ‹wellformed Γ]) auto

lemma trans_from_sterms':
  assumes "((ξ, p'), a, (ξ', q))  seqp_sos Γ"
      and "wellformed Γ"
      and "p'  sterms Γ p"
    shows "((ξ, p), a, (ξ', q))  seqp_sos Γ"
  using assms by (induction p rule: sterms_pinduct [OF ‹wellformed Γ]) auto

lemma trans_to_dterms:
  assumes "((ξ, p), a, (ξ', q))  seqp_sos Γ"
      and "wellformed Γ"
   shows "rsterms Γ q. r  dterms Γ p"
  using assms by (induction q) auto

theorem cterms_includes_sterms_of_seq_reachable:
  assumes "wellformed Γ"
      and "control_within Γ (init A)"
      and "trans A = seqp_sos Γ"
    shows "(sterms Γ ` snd ` reachable A I)  cterms Γ"
  proof
    fix qs
    assume "qs  (sterms Γ ` snd ` reachable A I)"
    then obtain ξ and q where  *: "(ξ, q)  reachable A I"
                          and **: "qs  sterms Γ q" by auto
    from * have "x. x  sterms Γ q  x  cterms Γ"
    proof (induction rule: reachable_pair_induct)
      fix ξ p q
      assume "(ξ, p)  init A"
         and "q  sterms Γ p"
      from ‹control_within Γ (init A) and (ξ, p)  init A
        obtain pn where "p  subterms (Γ pn)" by auto
      with ‹wellformed Γ show "q  cterms Γ" using qsterms Γ p
        by (rule subterms_sterms_in_cterms)
    next
      fix p ξ a ξ' q x
      assume "(ξ, p)  reachable A I"
         and IH: "x. x  sterms Γ p  x  cterms Γ"
         and "((ξ, p), a, (ξ', q))  trans A"
         and "x  sterms Γ q"
      from this(3) and ‹trans A = seqp_sos Γ have "((ξ, p), a, (ξ', q))  seqp_sos Γ" by simp
      from this and ‹wellformed Γ obtain ps
        where ps: "ps  sterms Γ p"
          and step: "((ξ, ps), a, (ξ', q))  seqp_sos Γ"
        by (rule trans_from_sterms [THEN bexE])
      from ps have "ps  cterms Γ" by (rule IH)
      moreover from step ‹wellformed Γ x  sterms Γ q have "x  dterms Γ ps"
        by (rule trans_to_dterms [rule_format])
      ultimately show "x  cterms Γ" by (rule ctermsDI)
    qed
    thus "qs  cterms Γ" using ** .
  qed

corollary seq_reachable_in_cterms:
  assumes "wellformed Γ"
      and "control_within Γ (init A)"
      and "trans A = seqp_sos Γ"
      and "(ξ, p)  reachable A I"
      and "p'  sterms Γ p"
    shows "p'  cterms Γ"
  using assms(1-3)
  proof (rule cterms_includes_sterms_of_seq_reachable [THEN subsetD])
    from assms(4-5) show "p'  (sterms Γ ` snd ` reachable A I)"
      by (auto elim!: rev_bexI)
  qed

lemma seq_invariant_ctermI:
  assumes wf: "wellformed Γ"
      and cw: "control_within Γ (init A)"
      and sl: "simple_labels Γ"
      and sp: "trans A = seqp_sos Γ"
      and init: "ξ p l. 
                   (ξ, p)  init A;
                   llabels Γ p
                   P (ξ, l)"
      and step: "p l ξ a q l' ξ' pp. 
                 pcterms Γ;
                 llabels Γ p;
                 P (ξ, l);
                 ((ξ, p), a, (ξ', q))  seqp_sos Γ;
                 ((ξ, p), a, (ξ', q))  trans A;
                 l'labels Γ q;
                 (ξ, pp)reachable A I;
                 psterms Γ pp;
                 (ξ', q)reachable A I;
                 I a
                 P (ξ', l')"
    shows "A  (I →) onl Γ P"
  proof
       fix ξ p l
    assume "(ξ, p)  init A"
       and *: "l  labels Γ p"
      with init show "P (ξ, l)" by auto
  next
       fix ξ p a ξ' q l'
    assume sr: "(ξ, p)  reachable A I"
       and pl: "llabels Γ p. P (ξ, l)"
       and tr: "((ξ, p), a, (ξ', q))  trans A"
       and A6: "l'  labels Γ q"
       and "I a"
     from this(3) and ‹trans A = seqp_sos Γ have tr': "((ξ, p), a, (ξ', q))  seqp_sos Γ" by simp
     show "P (ξ', l')"
    proof -
      from sr and tr and I a have A7: "(ξ', q)  reachable A I" ..
      from tr' obtain p' where "p'  sterms Γ p"
                           and "((ξ, p'), a, (ξ', q))  seqp_sos Γ"
        by (blast dest: trans_from_sterms [OF _ wf])
      from wf cw sp sr this(1) have A1: "p'cterms Γ"
        by (rule seq_reachable_in_cterms)
      from labels_not_empty [OF wf] obtain ll where A2: "lllabels Γ p'"
          by blast
      with p'sterms Γ p have "lllabels Γ p"
        by (rule labels_sterms_labels [OF wf])
      with pl have A3: "P (ξ, ll)" by simp
      from ((ξ, p'), a, (ξ', q))  seqp_sos Γ and sp
        have A5: "((ξ, p'), a, (ξ', q))  trans A" by simp
      with sp have A4: "((ξ, p'), a, (ξ', q))  seqp_sos Γ" by simp
      from sr p'sterms Γ p
        obtain pp where A7: "(ξ, pp)reachable A I"
                    and A8: "p'sterms Γ pp"
        by auto
      from sr tr I a have A9: "(ξ', q)  reachable A I" ..
      from A1 A2 A3 A4 A5 A6 A7 A8 A9 I a show ?thesis by (rule step)
    qed
  qed

lemma seq_invariant_ctermsI:
  assumes wf: "wellformed Γ"
      and "control_within Γ (init A)"
      and "simple_labels Γ"
      and "trans A = seqp_sos Γ"
      and init: "ξ p l. 
                   (ξ, p)  init A;
                   llabels Γ p
                   P (ξ, l)"
      and step: "p l ξ a q l' ξ' pp pn. 
                 wellformed Γ;
                 pctermsl (Γ pn);
                 not_call p;
                 llabels Γ p;
                 P (ξ, l);
                 ((ξ, p), a, (ξ', q))  seqp_sos Γ;
                 ((ξ, p), a, (ξ', q))  trans A;
                 l'labels Γ q;
                 (ξ, pp)reachable A I;
                 psterms Γ pp;
                 (ξ', q)reachable A I;
                 I a
                 P (ξ', l')"
    shows "A  (I →) onl Γ P"
  using assms(1-4) proof (rule seq_invariant_ctermI)
    fix ξ p l
    assume "(ξ, p)  init A"
       and "l  labels Γ p"
    thus "P (ξ, l)" by (rule init)
  next
    fix p l ξ a q l' ξ' pp
    assume "p  cterms Γ"
       and otherassms: "l  labels Γ p"
           "P (ξ, l)"
           "((ξ, p), a, (ξ', q))  seqp_sos Γ"
           "((ξ, p), a, (ξ', q))  trans A"
           "l'  labels Γ q"
           "(ξ, pp)  reachable A I"
           "p  sterms Γ pp"
           "(ξ', q)  reachable A I"
           "I a"
    from this(1) obtain pn where "p  ctermsl(Γ pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P (ξ', l')"
      using otherassms by (rule step)
  qed

subsection "Step invariants via labelled control terms"

definition
  onll :: "('s, 'm, 'p, 'l) seqp_env
            (('z × 'l, 'a) transition  bool)
            ('z × ('s, 'm, 'p, 'l) seqp, 'a) transition  bool"
where
  "onll Γ P  (λ((ξ, p), a, (ξ', p')). llabels Γ p. l'labels Γ p'. P ((ξ, l), a, (ξ', l')))"

lemma onllI [intro]:
  assumes "l l'.  llabels Γ p; l'labels Γ p'   P ((ξ, l), a, (ξ', l'))"
    shows "onll Γ P ((ξ, p), a, (ξ', p'))"
  using assms unfolding onll_def by simp

lemma onllIl [intro]:
  assumes "llabels Γ p. l'labels Γ p'. P ((ξ, l), a, (ξ', l'))"
    shows "onll Γ P ((ξ, p), a, (ξ', p'))"
  using assms by auto

lemma onllD [dest]:
  assumes "onll Γ P ((ξ, p), a, (ξ', p'))"
    shows "llabels Γ p. l'labels Γ p'. P ((ξ, l), a, (ξ', l'))"
  using assms unfolding onll_def by simp

lemma onl_weaken [elim!]: "Γ P Q s.  onl Γ P s; s. P s  Q s   onl Γ Q s"
  by (clarsimp dest!: onlD intro!: onlI)

lemma onll_weaken [elim!]: "Γ P Q s.  onll Γ P s; s. P s  Q s   onll Γ Q s"
  by (clarsimp dest!: onllD intro!: onllI)

lemma onll_weaken' [elim!]: "Γ P Q s.  onll Γ P ((ξ, p), a, (ξ', p'));
                                        l l'. P ((ξ, l), a, (ξ', l'))  Q ((ξ, l), a, (ξ', l')) 
                                       onll Γ Q ((ξ, p), a, (ξ', p'))"
  by (clarsimp dest!: onllD intro!: onllI)

lemma onll_step_invariantI [intro]:
  assumes *: "ξ p l a ξ' p' l'.  (ξ, p)reachable A I;
                                   ((ξ, p), a, (ξ', p'))  trans A;
                                   I a;
                                   l labels Γ p;
                                   l'labels Γ p' 
                                  P ((ξ, l), a, (ξ', l'))"
    shows "A A (I →) onll Γ P"
  proof
    fix ξ p ξ' p' a
    assume "(ξ, p)  reachable A I"
       and "((ξ, p), a, (ξ', p'))  trans A"
       and "I a"
    hence "llabels Γ p. l'labels Γ p'. P ((ξ, l), a, (ξ', l'))" by (auto elim!: *)
    thus "onll Γ P ((ξ, p), a, (ξ', p'))" ..
  qed

lemma onll_step_invariantE [elim]:
  assumes "A A (I →) onll Γ P"
      and "(ξ, p)  reachable A I"
      and "((ξ, p), a, (ξ', p'))  trans A"
      and "I a"
      and lp:  "l labels Γ p"
      and lp': "l'labels Γ p'"
    shows "P ((ξ, l), a, (ξ', l'))"
  proof -
    from assms(1-4) have "onll Γ P ((ξ, p), a, (ξ', p'))" ..
    with lp lp' show "P ((ξ, l), a, (ξ', l'))" by auto
  qed

lemma onll_step_invariantD [dest]:
  assumes "A A (I →) onll Γ P"
      and "(ξ, p)  reachable A I"
      and "((ξ, p), a, (ξ', p'))  trans A"
      and "I a"
    shows "llabels Γ p. l'labels Γ p'. P ((ξ, l), a, (ξ', l'))"
  using assms by auto

lemma onll_step_to_invariantI [intro]:
  assumes sinv: "A A (I →) onll Γ Q"
      and wf: "wellformed Γ"
      and init: "ξ l p.  (ξ, p)  init A; llabels Γ p   P (ξ, l)"
      and step: "ξ p l ξ' l' a.
                    (ξ, p)  reachable A I;
                     llabels Γ p;
                     P (ξ, l);
                     Q ((ξ, l), a, (ξ', l'));
                     I a  P (ξ', l')"
    shows "A  (I →) onl Γ P"
  proof
    fix ξ p l
    assume "(ξ, p)  init A" and "llabels Γ p"
      thus "P (ξ, l)" by (rule init)
  next
    fix ξ p a ξ' p' l'
    assume sr: "(ξ, p)  reachable A I"
       and lp: "llabels Γ p. P (ξ, l)"
       and tr: "((ξ, p), a, (ξ', p'))  trans A"
       and "I a"
       and lp': "l'  labels Γ p'"
      show "P (ξ', l')"
    proof -
      from lp obtain l where "llabels Γ p" and "P (ξ, l)"
        using labels_not_empty [OF wf] by auto
      from sinv sr tr I a this(1) lp' have "Q ((ξ, l), a, (ξ', l'))" ..
      with sr llabels Γ p P (ξ, l) show "P (ξ', l')" using I a by (rule step)
    qed
  qed

lemma onll_step_invariant_sterms:
  assumes wf: "wellformed Γ"
      and si: "A A (I →) onll Γ P"
      and sr: "(ξ, p)  reachable A I"
      and sos: "((ξ, p), a, (ξ', q))  trans A"
      and "I a"
      and "l'labels Γ q"
      and "p'sterms Γ p"
      and "llabels Γ p'"
    shows "P ((ξ, l), a, (ξ', l'))"
  proof -
    from wf p'sterms Γ p llabels Γ p' have "llabels Γ p"
      by (rule labels_sterms_labels)
    with si sr sos I a show "P ((ξ, l), a, (ξ', l'))" using l'labels Γ q ..
  qed

lemma seq_step_invariant_sterms:
  assumes inv: "A A (I →) onll Γ P"
      and wf: "wellformed Γ"
      and sp: "trans A = seqp_sos Γ"
      and "l'labels Γ q"
      and sr: "(ξ, p)  reachable A I"
      and tr: "((ξ, p'), a, (ξ', q))  trans A"
      and "I a"
      and "p'sterms Γ p"
    shows "llabels Γ p'. P ((ξ, l), a, (ξ', l'))"
  proof
    from tr and sp have "((ξ, p'), a, (ξ', q))  seqp_sos Γ" by simp
    hence "((ξ, p), a, (ξ', q))  seqp_sos Γ"
      using wf p'sterms Γ p by  (rule trans_from_sterms')
    with sp have trp: "((ξ, p), a, (ξ', q))  trans A" by simp
    fix l assume "l  labels Γ p'"
    with wf inv sr trp I a l'labels Γ q p'sterms Γ p
      show "P ((ξ, l), a, (ξ', l'))" by (rule onll_step_invariant_sterms)
  qed

lemma seq_step_invariant_sterms_weaken:
  assumes "A A (I →) onll Γ P"
      and "wellformed Γ"
      and "trans A = seqp_sos Γ"
      and "l'labels Γ q"
      and "(ξ, p)  reachable A I'"
      and "((ξ, p'), a, (ξ', q))  trans A"
      and "I' a"
      and "p'sterms Γ p"
      and weaken: "a. I' a  I a"
    shows "llabels Γ p'. P ((ξ, l), a, (ξ', l'))"
  proof -
    from I' a have "I a" by (rule weaken)
    from (ξ, p)  reachable A I' have Ir: "(ξ, p)  reachable A I"
        by (rule reachable_weakenE) (erule weaken)
    with assms(1-4) show ?thesis
      using ((ξ, p'), a, (ξ', q))  trans A I a and p'sterms Γ p
      by (rule seq_step_invariant_sterms)
  qed

lemma seq_step_invariant_sterms_TT:
  assumes "A A onll Γ P"
      and "wellformed Γ"
      and "trans A = seqp_sos Γ"
      and "l'labels Γ q"
      and "(ξ, p)  reachable A I"
      and "((ξ, p'), a, (ξ', q))  trans A"
      and "I a"
      and "p'sterms Γ p"
    shows "llabels Γ p'. P ((ξ, l), a, (ξ', l'))"
  using assms by (rule seq_step_invariant_sterms_weaken) simp

lemma onll_step_invariant_any_sterms:
  assumes "wellformed Γ"
      and "A A (I →) onll Γ P"
      and "(ξ, p)  reachable A I"
      and "((ξ, p), a, (ξ', q))  trans A"
      and "I a"
      and "l'labels Γ q"
    shows "p'sterms Γ p. llabels Γ p'. P ((ξ, l), a, (ξ', l'))"
  by (intro ballI) (rule onll_step_invariant_sterms [OF assms])

lemma seq_step_invariant_ctermI [intro]:
  assumes wf: "wellformed Γ"
      and cw: "control_within Γ (init A)"
      and sl: "simple_labels Γ"
      and sp: "trans A = seqp_sos Γ"
      and step: "p pp l ξ a q l' ξ'. 
                 pcterms Γ;
                 llabels Γ p;
                 ((ξ, p), a, (ξ', q))  seqp_sos Γ;
                 ((ξ, p), a, (ξ', q))  trans A;
                 l'labels Γ q;
                 (ξ, pp)  reachable A I;
                 psterms Γ pp;
                 (ξ', q)  reachable A I;
                 I a
                 P ((ξ, l), a, (ξ', l'))"
    shows "A A (I →) onll Γ P"
  proof
       fix ξ p l a ξ' q l'
    assume sr: "(ξ, p)  reachable A I"
       and tr: "((ξ, p), a, (ξ', q))  trans A"
       and "I a"
       and pl: "l  labels Γ p"
       and A5: "l'  labels Γ q"
    from this(2) and sp have tr': "((ξ, p), a, (ξ', q))  seqp_sos Γ" by simp
    then obtain p' where "p'  sterms Γ p"
                     and A3: "((ξ, p'), a, (ξ', q))  seqp_sos Γ"
      by (blast dest: trans_from_sterms [OF _ wf])
    from wf cw sp sr this(1) have A1: "p'cterms Γ"
      by (rule seq_reachable_in_cterms)
    from ((ξ, p'), a, (ξ', q))  seqp_sos Γ and sp
      have A4: "((ξ, p'), a, (ξ', q))  trans A" by simp
    from sr p'sterms Γ p obtain pp where A6: "(ξ, pp)reachable A I"
                                        and A7: "p'sterms Γ pp"
      by auto
    from sr tr I a have A8: "(ξ', q)reachable A I" ..
    from wf cw sp sr have "pn. p  subterms (Γ pn)"
      by (rule reachable_subterms)
    with sl wf have "p'sterms Γ p. l  labels Γ p'"
      using pl by (rule simple_labels_in_sterms)
    with p'  sterms Γ p have "l  labels Γ p'" by simp
    with A1 show "P ((ξ, l), a, (ξ', l'))" using A3 A4 A5 A6 A7 A8 I a
      by (rule step)
  qed

lemma seq_step_invariant_ctermsI [intro]:
  assumes wf: "wellformed Γ"
      and cw: "control_within Γ (init A)"
      and sl: "simple_labels Γ"
      and sp: "trans A = seqp_sos Γ"
      and step: "p l ξ a q l' ξ' pp pn. 
                 wellformed Γ;
                 pctermsl (Γ pn);
                 not_call p;
                 llabels Γ p;
                 ((ξ, p), a, (ξ', q))  seqp_sos Γ;
                 ((ξ, p), a, (ξ', q))  trans A;
                 l'labels Γ q;
                 (ξ, pp)  reachable A I;
                 psterms Γ pp;
                 (ξ', q)  reachable A I;
                 I a
                 P ((ξ, l), a, (ξ', l'))"
    shows "A A (I →) onll Γ P"
  using assms(1-4) proof (rule seq_step_invariant_ctermI)
    fix p pp l ξ a q l' ξ'
    assume "p  cterms Γ"
       and otherassms: "l  labels Γ p"
           "((ξ, p), a, (ξ', q))  seqp_sos Γ"
           "((ξ, p), a, (ξ', q))  trans A"
           "l'  labels Γ q"
           "(ξ, pp)  reachable A I"
           "p  sterms Γ pp"
           "(ξ', q)  reachable A I"
           "I a"
    from this(1) obtain pn where "p  ctermsl(Γ pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P ((ξ, l), a, (ξ', l'))"
      using otherassms by (rule step)
  qed

end

Theory OAWN_Invariants

(*  Title:       OAWN_Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Generic open invariants on sequential AWN processes"

theory OAWN_Invariants
imports Invariants OInvariants
        AWN_Cterms AWN_Labels AWN_Invariants
        OAWN_SOS
begin

subsection "Open invariants via labelled control terms"

lemma oseqp_sos_subterms:
  assumes "wellformed Γ"
      and "pn. p  subterms (Γ pn)"
      and "((σ, p), a, (σ', p'))  oseqp_sos Γ i"
    shows "pn. p'  subterms (Γ pn)"
  using assms
  proof (induct p)
    fix p1 p2
    assume IH1: "pn. p1  subterms (Γ pn) 
                      ((σ, p1), a, (σ', p'))  oseqp_sos Γ i 
                      pn. p'  subterms (Γ pn)"
       and IH2: "pn. p2  subterms (Γ pn) 
                      ((σ, p2), a, (σ', p'))  oseqp_sos Γ i 
                      pn. p'  subterms (Γ pn)"
       and "pn. p1  p2  subterms (Γ pn)"
       and "((σ, p1  p2), a, (σ', p'))  oseqp_sos Γ i"
    from pn. p1  p2  subterms (Γ pn) obtain pn
                                            where "p1  subterms (Γ pn)"
                                              and "p2  subterms (Γ pn)" by auto
    from ((σ, p1  p2), a, (σ', p'))  oseqp_sos Γ i
      have "((σ, p1), a, (σ', p'))  oseqp_sos Γ i
             ((σ, p2), a, (σ', p'))  oseqp_sos Γ i" by auto
    thus "pn. p'  subterms (Γ pn)"
    proof
      assume "((σ, p1), a, (σ', p'))  oseqp_sos Γ i"
      with p1  subterms (Γ pn) show ?thesis by (auto intro: IH1)
    next
      assume "((σ, p2), a, (σ', p'))  oseqp_sos Γ i"
      with p2  subterms (Γ pn) show ?thesis by (auto intro: IH2)
    qed
  qed auto

lemma oreachable_subterms:
  assumes "wellformed Γ"
      and "control_within Γ (init A)"
      and "trans A = oseqp_sos Γ i"
      and "(σ, p)  oreachable A S U"
    shows "pn. p  subterms (Γ pn)"
  using assms(4)
  proof (induct rule: oreachable_pair_induct)
    fix σ p
    assume "(σ, p)  init A"
    with ‹control_within Γ (init A) show "pn. p  subterms (Γ pn)" ..
  next
    fix σ p a σ' p'
    assume "(σ, p)  oreachable A S U"
       and "pn. p  subterms (Γ pn)"
       and 3: "((σ, p), a, (σ', p'))  trans A"
       and "S σ σ' a"
    moreover from 3 and ‹trans A = oseqp_sos Γ i
      have "((σ, p), a, (σ', p'))  oseqp_sos Γ i" by simp
    ultimately show "pn. p'  subterms (Γ pn)"
    using ‹wellformed Γ
      by (auto elim: oseqp_sos_subterms)
  qed

lemma onl_oinvariantI [intro]:
  assumes init: "σ p l.  (σ, p)  init A; l  labels Γ p   P (σ, l)"
      and other: "σ σ' p l.  (σ, p)  oreachable A S U;
                                llabels Γ p. P (σ, l);
                                U σ σ'   llabels Γ p. P (σ', l)"
      and step: "σ p a σ' p' l'.
                    (σ, p)  oreachable A S U;
                     llabels Γ p. P (σ, l);
                     ((σ, p), a, (σ', p'))  trans A;
                     l'  labels Γ p';
                     S σ σ' a   P (σ', l')"
    shows "A  (S, U →) onl Γ P"
  proof
    fix σ p
    assume "(σ, p)  init A"
    hence "llabels Γ p. P (σ, l)" using init by simp
    thus "onl Γ P (σ, p)" ..
  next
    fix σ p a σ' p'
    assume rp: "(σ, p)  oreachable A S U"
       and "onl Γ P (σ, p)"
       and tr: "((σ, p), a, (σ', p'))  trans A"
       and "S σ σ' a"
    from ‹onl Γ P (σ, p) have "llabels Γ p. P (σ, l)" ..
    with rp tr S σ σ' a have "l'labels Γ p'. P (σ', l')" by (auto elim: step)
    thus "onl Γ P (σ', p')" ..
  next
    fix σ σ' p
    assume "(σ, p)  oreachable A S U"
       and "onl Γ P (σ, p)"
       and "U σ σ'"
    from ‹onl Γ P (σ, p) have "llabels Γ p. P (σ, l)" by auto
    with (σ, p)  oreachable A S U have "llabels Γ p. P (σ', l)"
        using U σ σ' by (rule other)
    thus "onl Γ P (σ', p)" by auto
  qed

lemma global_oinvariantI [intro]:
  assumes init: "σ p. (σ, p)  init A  P σ"
      and other: "σ σ' p l.  (σ, p)  oreachable A S U; P σ; U σ σ'   P σ'"
      and step: "σ p a σ' p'.
                    (σ, p)  oreachable A S U;
                     P σ;
                     ((σ, p), a, (σ', p'))  trans A;
                     S σ σ' a   P σ'"
    shows "A  (S, U →) (λ(σ, _). P σ)"
  proof
    fix σ p
    assume "(σ, p)  init A"
    thus "(λ(σ, _). P σ) (σ, p)"
      by simp (erule init)
  next
    fix σ p a σ' p'
    assume rp: "(σ, p)  oreachable A S U"
       and "(λ(σ, _). P σ) (σ, p)"
       and tr: "((σ, p), a, (σ', p'))  trans A"
       and "S σ σ' a"
    from (λ(σ, _). P σ) (σ, p) have "P σ" by simp
    with rp have "P σ'"
      using tr S σ σ' a by (rule step)
    thus "(λ(σ, _). P σ) (σ', p')" by simp
  next
    fix σ σ' p
    assume "(σ, p)  oreachable A S U"
       and "(λ(σ, _). P σ) (σ, p)"
       and "U σ σ'"
    hence "P σ'" by simp (erule other)
    thus "(λ(σ, _). P σ) (σ', p)" by simp
  qed

lemma onl_oinvariantD [dest]:
  assumes "A  (S, U →) onl Γ P"
      and "(σ, p)  oreachable A S U"
      and "l  labels Γ p"
    shows "P (σ, l)"
  using assms unfolding onl_def by auto

lemma onl_oinvariant_weakenD [dest]:
  assumes "A  (S', U' →) onl Γ P"
      and "(σ, p)  oreachable A S U"
      and "l  labels Γ p"
      and weakenS: "s s' a. S s s' a  S' s s' a"
      and weakenU: "s s'. U s s'  U' s s'"
    shows "P (σ, l)"
  proof -
    from (σ, p)  oreachable A S U have "(σ, p)  oreachable A S' U'"
      by (rule oreachable_weakenE)
         (erule weakenS, erule weakenU)
    with A  (S', U' →) onl Γ P show "P (σ, l)"
      using l  labels Γ p ..
  qed

lemma onl_oinvariant_initD [dest]:
  assumes invP: "A  (S, U →) onl Γ P"
      and init: "(σ, p)  init A"
      and pnl:  "l  labels Γ p"
    shows "P (σ, l)"
  proof -
    from init have "(σ, p)  oreachable A S U" ..
    with invP show ?thesis using pnl ..
  qed

lemma onl_oinvariant_sterms:
  assumes wf: "wellformed Γ"
      and il: "A  (S, U →) onl Γ P"
      and rp: "(σ, p)  oreachable A S U"
      and "p'sterms Γ p"
      and "llabels Γ p'"
    shows "P (σ, l)"
  proof -
    from wf p'sterms Γ p llabels Γ p' have "llabels Γ p"
      by (rule labels_sterms_labels)
    with il rp show "P (σ, l)" ..
  qed

lemma onl_oinvariant_sterms_weaken:
  assumes wf: "wellformed Γ"
      and il: "A  (S', U' →) onl Γ P"
      and rp: "(σ, p)  oreachable A S U"
      and "p'sterms Γ p"
      and "llabels Γ p'"
      and weakenS: "σ σ' a. S σ σ' a  S' σ σ' a"
      and weakenU: "σ σ'. U σ σ'  U' σ σ'"
    shows "P (σ, l)"
  proof -
    from (σ, p)  oreachable A S U have "(σ, p)  oreachable A S' U'"
      by (rule oreachable_weakenE)
         (erule weakenS, erule weakenU)
    with assms(1-2) show ?thesis using assms(4-5)
      by (rule onl_oinvariant_sterms)
  qed

lemma otrans_from_sterms:
  assumes "((σ, p), a, (σ', q))  oseqp_sos Γ i"
      and "wellformed Γ"
    shows "p'sterms Γ p. ((σ, p'), a, (σ', q))  oseqp_sos Γ i"
  using assms by (induction p rule: sterms_pinduct [OF ‹wellformed Γ]) auto

lemma otrans_from_sterms':
  assumes "((σ, p'), a, (σ', q))  oseqp_sos Γ i"
      and "wellformed Γ"
      and "p'  sterms Γ p"
    shows "((σ, p), a, (σ', q))  oseqp_sos Γ i"
  using assms by (induction p rule: sterms_pinduct [OF ‹wellformed Γ]) auto

lemma otrans_to_dterms:
  assumes "((σ, p), a, (σ', q))  oseqp_sos Γ i"
      and "wellformed Γ"
   shows "rsterms Γ q. r  dterms Γ p"
  using assms by (induction q) auto

theorem cterms_includes_sterms_of_oseq_reachable:
  assumes "wellformed Γ"
      and "control_within Γ (init A)"
      and "trans A = oseqp_sos Γ i"
    shows "(sterms Γ ` snd ` oreachable A S U)  cterms Γ"
  proof
    fix qs
    assume "qs  (sterms Γ ` snd ` oreachable A S U)"
    then obtain ξ and q where  *: "(ξ, q)  oreachable A S U"
                          and **: "qs  sterms Γ q" by auto
    from * have "x. x  sterms Γ q  x  cterms Γ"
    proof (induction rule: oreachable_pair_induct)
      fix σ p q
      assume "(σ, p)  init A"
         and "q  sterms Γ p"
      from ‹control_within Γ (init A) and (σ, p)  init A
        obtain pn where "p  subterms (Γ pn)" by auto
      with ‹wellformed Γ show "q  cterms Γ" using qsterms Γ p
        by (rule subterms_sterms_in_cterms)
    next
      fix p σ a σ' q x
      assume "(σ, p)  oreachable A S U"
         and IH: "x. x  sterms Γ p  x  cterms Γ"
         and "((σ, p), a, (σ', q))  trans A"
         and "x  sterms Γ q"
      from this(3) and ‹trans A = oseqp_sos Γ i
        have step: "((σ, p), a, (σ', q))  oseqp_sos Γ i" by simp
      from step ‹wellformed Γ obtain ps
        where ps: "ps  sterms Γ p"
          and step': "((σ, ps), a, (σ', q))  oseqp_sos Γ i"
        by (rule otrans_from_sterms [THEN bexE])
      from ps have "ps  cterms Γ" by (rule IH)
      moreover from step' ‹wellformed Γ x  sterms Γ q have "x  dterms Γ ps"
        by (rule otrans_to_dterms [rule_format])
      ultimately show "x  cterms Γ" by (rule ctermsDI)
    qed
    thus "qs  cterms Γ" using ** .
  qed

corollary oseq_reachable_in_cterms:
  assumes "wellformed Γ"
      and "control_within Γ (init A)"
      and "trans A = oseqp_sos Γ i"
      and "(σ, p)  oreachable A S U"
      and "p'  sterms Γ p"
    shows "p'  cterms Γ"
  using assms(1-3)
  proof (rule cterms_includes_sterms_of_oseq_reachable [THEN subsetD])
    from assms(4-5) show "p'  (sterms Γ ` snd ` oreachable A S U)"
      by (auto elim!: rev_bexI)
  qed

lemma oseq_invariant_ctermI:
  assumes wf: "wellformed Γ"
      and cw: "control_within Γ (init A)"
      and sl: "simple_labels Γ"
      and sp: "trans A = oseqp_sos Γ i"
      and init: "σ p l. 
                   (σ, p)  init A;
                   llabels Γ p
                   P (σ, l)"
      and other: "σ σ' p l. 
                   (σ, p)  oreachable A S U;
                   llabels Γ p;
                   P (σ, l);
                   U σ σ'   P (σ', l)"
      and local: "p l σ a q l' σ' pp. 
                 pcterms Γ;
                 llabels Γ p;
                 P (σ, l);
                 ((σ, p), a, (σ', q))  oseqp_sos Γ i;
                 ((σ, p), a, (σ', q))  trans A;
                 l'labels Γ q;
                 (σ, pp)oreachable A S U;
                 psterms Γ pp;
                 (σ', q)oreachable A S U;
                 S σ σ' a
                 P (σ', l')"
    shows "A  (S, U →) onl Γ P"
  proof
       fix σ p l
    assume "(σ, p)  init A"
       and *: "l  labels Γ p"
      with init show "P (σ, l)" by auto
  next
       fix σ p a σ' q l'
    assume sr: "(σ, p)  oreachable A S U"
       and pl: "llabels Γ p. P (σ, l)"
       and tr: "((σ, p), a, (σ', q))  trans A"
       and A6: "l'  labels Γ q"
       and "S σ σ' a"
      thus "P (σ', l')"
    proof -
      from sr and tr and S σ σ' a have A7: "(σ', q)  oreachable A S U"
        by - (rule oreachable_local')
      from tr and sp have tr': "((σ, p), a, (σ', q))  oseqp_sos Γ i" by simp
      then obtain p' where "p'  sterms Γ p"
                       and A4: "((σ, p'), a, (σ', q))  oseqp_sos Γ i"
        by (blast dest: otrans_from_sterms [OF _ wf])
      from wf cw sp sr this(1) have A1: "p'cterms Γ"
        by (rule oseq_reachable_in_cterms)
      from labels_not_empty [OF wf] obtain ll where A2: "lllabels Γ p'"
          by blast
      with p'sterms Γ p have "lllabels Γ p"
        by (rule labels_sterms_labels [OF wf])
      with pl have A3: "P (σ, ll)" by simp
      from sr p'sterms Γ p
        obtain pp where A7: "(σ, pp)oreachable A S U"
                    and A8: "p'sterms Γ pp"
        by auto
      from sr tr S σ σ' a have A9: "(σ', q)oreachable A S U"
        by - (rule oreachable_local')
      from sp and ((σ, p'), a, (σ', q))  oseqp_sos Γ i
        have A5: "((σ, p'), a, (σ', q))  trans A" by simp
      from A1 A2 A3 A4 A5 A6 A7 A8 A9 S σ σ' a show ?thesis by (rule local)
    qed
  next
    fix σ σ' p l
    assume sr: "(σ, p)  oreachable A S U"
       and "llabels Γ p. P (σ, l)"
       and "U σ σ'"
    show "llabels Γ p. P (σ', l)"
    proof
      fix l
      assume "llabels Γ p"
      with llabels Γ p. P (σ, l) have "P (σ, l)" ..
      with sr and llabels Γ p
        show "P (σ', l)" using U σ σ' by (rule other)
    qed
  qed

lemma oseq_invariant_ctermsI:
  assumes wf: "wellformed Γ"
      and cw: "control_within Γ (init A)"
      and sl: "simple_labels Γ"
      and sp: "trans A = oseqp_sos Γ i"
      and init: "σ p l. 
                   (σ, p)  init A;
                   llabels Γ p
                   P (σ, l)"
      and other: "σ σ' p l. 
                   wellformed Γ;
                   (σ, p)  oreachable A S U;
                   llabels Γ p;
                   P (σ, l);
                   U σ σ'   P (σ', l)"
      and local: "p l σ a q l' σ' pp pn. 
                 wellformed Γ;
                 pctermsl (Γ pn);
                 not_call p;
                 llabels Γ p;
                 P (σ, l);
                 ((σ, p), a, (σ', q))  oseqp_sos Γ i;
                 ((σ, p), a, (σ', q))  trans A;
                 l'labels Γ q;
                 (σ, pp)oreachable A S U;
                 psterms Γ pp;
                 (σ', q)oreachable A S U;
                 S σ σ' a
                 P (σ', l')"
    shows "A  (S, U →) onl Γ P"
  proof (rule oseq_invariant_ctermI [OF wf cw sl sp])
    fix σ p l
    assume "(σ, p)  init A"
       and "l  labels Γ p"
    thus "P (σ, l)" by (rule init)
  next
    fix σ σ' p l
    assume "(σ, p)  oreachable A S U"
       and "l  labels Γ p"
       and "P (σ, l)"
       and "U σ σ'"
    with wf show "P (σ', l)" by (rule other)
  next
    fix p l σ a q l' σ' pp
    assume "p  cterms Γ"
       and otherassms: "l  labels Γ p"
           "P (σ, l)"
           "((σ, p), a, (σ', q))  oseqp_sos Γ i"
           "((σ, p), a, (σ', q))  trans A"
           "l'  labels Γ q"
           "(σ, pp)  oreachable A S U"
           "p  sterms Γ pp"
           "(σ', q)  oreachable A S U"
           "S σ σ' a"
    from this(1) obtain pn where "p  ctermsl(Γ pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P (σ', l')"
      using otherassms by (rule local)
  qed

subsection "Open step invariants via labelled control terms"

lemma onll_ostep_invariantI [intro]:
  assumes *: "σ p l a σ' p' l'.  (σ, p)oreachable A S U;
                                   ((σ, p), a, (σ', p'))  trans A;
                                   S σ σ' a;
                                   l labels Γ p;
                                   l'labels Γ p' 
                                  P ((σ, l), a, (σ', l'))"
    shows "A A (S, U →) onll Γ P"
  proof
    fix σ p σ' p' a
    assume "(σ, p)  oreachable A S U"
       and "((σ, p), a, (σ', p'))  trans A"
       and "S σ σ' a"
    hence "llabels Γ p. l'labels Γ p'. P ((σ, l), a, (σ', l'))" by (auto elim!: *)
    thus "onll Γ P ((σ, p), a, (σ', p'))" ..
  qed

lemma onll_ostep_invariantE [elim]:
  assumes "A A (S, U →) onll Γ P"
      and "(σ, p)  oreachable A S U"
      and "((σ, p), a, (σ', p'))  trans A"
      and "S σ σ' a"
      and lp:  "l labels Γ p"
      and lp': "l'labels Γ p'"
    shows "P ((σ, l), a, (σ', l'))"
  proof -
    from assms(1-4) have "onll Γ P ((σ, p), a, (σ', p'))" ..
    with lp lp' show "P ((σ, l), a, (σ', l'))" by auto
  qed

lemma onll_ostep_invariantD [dest]:
  assumes "A A (S, U →) onll Γ P"
      and "(σ, p)  oreachable A S U"
      and "((σ, p), a, (σ', p'))  trans A"
      and "S σ σ' a"
    shows "llabels Γ p. l'labels Γ p'. P ((σ, l), a, (σ', l'))"
  using assms by auto

lemma onll_ostep_invariant_weakenD [dest]:
  assumes "A A (S', U' →) onll Γ P"
      and "(σ, p)  oreachable A S U"
      and "((σ, p), a, (σ', p'))  trans A"
      and "S' σ σ' a"
      and weakenS: "s s' a. S s s' a  S' s s' a"
      and weakenU: "s s'. U s s'  U' s s'"
    shows "llabels Γ p. l'labels Γ p'. P ((σ, l), a, (σ', l'))"
  proof -
    from (σ, p)  oreachable A S U have "(σ, p)  oreachable A S' U'"
      by (rule oreachable_weakenE)
         (erule weakenS, erule weakenU)
    with A A (S', U' →) onll Γ P show ?thesis
      using ((σ, p), a, (σ', p'))  trans A and S' σ σ' a ..
  qed

lemma onll_ostep_to_invariantI [intro]:
  assumes sinv: "A A (S, U →) onll Γ Q"
      and wf: "wellformed Γ"
      and init: "σ l p.  (σ, p)  init A; llabels Γ p   P (σ, l)"
      and other: "σ σ' p l.
                     (σ, p)  oreachable A S U;
                      llabels Γ p;
                      P (σ, l);
                      U σ σ'   P (σ', l)"
      and local: "σ p l σ' l' a.
                     (σ, p)  oreachable A S U;
                      llabels Γ p;
                      P (σ, l);
                      Q ((σ, l), a, (σ', l'));
                      S σ σ' a  P (σ', l')"
    shows "A  (S, U →) onl Γ P"
  proof
    fix σ p l
    assume "(σ, p)  init A" and "llabels Γ p"
      thus "P (σ, l)" by (rule init)
  next
    fix σ p a σ' p' l'
    assume sr: "(σ, p)  oreachable A S U"
       and lp: "llabels Γ p. P (σ, l)"
       and tr: "((σ, p), a, (σ', p'))  trans A"
       and "S σ σ' a"
       and lp': "l'  labels Γ p'"
      show "P (σ', l')"
    proof -
      from lp obtain l where "llabels Γ p" and "P (σ, l)"
        using labels_not_empty [OF wf] by auto
      from sinv sr tr S σ σ' a this(1) lp' have "Q ((σ, l), a, (σ', l'))" ..
      with sr llabels Γ p P (σ, l) show "P (σ', l')" using S σ σ' a by (rule local)
    qed
  next
    fix σ σ' p l
    assume "(σ, p)  oreachable A S U"
       and "llabels Γ p. P (σ, l)"
       and "U σ σ'"
      show "llabels Γ p. P (σ', l)"
    proof
      fix l
      assume "llabels Γ p"
      with llabels Γ p. P (σ, l) have "P (σ, l)" ..
      with (σ, p)  oreachable A S U and llabels Γ p
      show "P (σ', l)" using U σ σ' by (rule other)
    qed
  qed

lemma onll_ostep_invariant_sterms:
  assumes wf: "wellformed Γ"
      and si: "A A (S, U →) onll Γ P"
      and sr: "(σ, p)  oreachable A S U"
      and sos: "((σ, p), a, (σ', q))  trans A"
      and "S σ σ' a"
      and "l'labels Γ q"
      and "p'sterms Γ p"
      and "llabels Γ p'"
    shows "P ((σ, l), a, (σ', l'))"
  proof -
    from wf p'sterms Γ p llabels Γ p' have "llabels Γ p"
      by (rule labels_sterms_labels)
    with si sr sos S σ σ' a show "P ((σ, l), a, (σ', l'))" using l'labels Γ q ..
  qed

lemma oseq_step_invariant_sterms:
  assumes inv: "A A (S, U →) onll Γ P"
      and wf: "wellformed Γ"
      and sp: "trans A = oseqp_sos Γ i"
      and "l'labels Γ q"
      and sr: "(σ, p)  oreachable A S U"
      and tr: "((σ, p'), a, (σ', q))  trans A"
      and "S σ σ' a"
      and "p'sterms Γ p"
    shows "llabels Γ p'. P ((σ, l), a, (σ', l'))"
  proof
    from assms(3, 6) have "((σ, p'), a, (σ', q))  oseqp_sos Γ i" by simp
    hence "((σ, p), a, (σ', q))  oseqp_sos Γ i"
      using wf p'sterms Γ p  by (rule otrans_from_sterms')
    with assms(3) have trp: "((σ, p), a, (σ', q))  trans A" by simp
    fix l assume "l  labels Γ p'"
    with wf inv sr trp S σ σ' a l'labels Γ q p'sterms Γ p
      show "P ((σ, l), a, (σ', l'))"
        by - (erule(7) onll_ostep_invariant_sterms)
  qed

lemma oseq_step_invariant_sterms_weaken:
  assumes inv: "A A (S, U →) onll Γ P"
      and wf: "wellformed Γ"
      and sp: "trans A = oseqp_sos Γ i"
      and "l'labels Γ q"
      and sr: "(σ, p)  oreachable A S' U'"
      and tr: "((σ, p'), a, (σ', q))  trans A"
      and "S' σ σ' a"
      and "p'sterms Γ p"
      and weakenS: "σ σ' a. S' σ σ' a  S σ σ' a"
      and weakenU: "σ σ'. U' σ σ'  U σ σ'"
    shows "llabels Γ p'. P ((σ, l), a, (σ', l'))"
  proof -
    from S' σ σ' a have "S σ σ' a" by (rule weakenS)
    from (σ, p)  oreachable A S' U'
      have Ir: "(σ, p)  oreachable A S U"
        by (rule oreachable_weakenE)
           (erule weakenS, erule weakenU)
    with assms(1-4) show ?thesis
      using tr S σ σ' a p'sterms Γ p
      by (rule oseq_step_invariant_sterms)
  qed

lemma onll_ostep_invariant_any_sterms:
  assumes wf: "wellformed Γ"
      and si: "A A (S, U →) onll Γ P"
      and sr: "(σ, p)  oreachable A S U"
      and sos: "((σ, p), a, (σ', q))  trans A"
      and "S σ σ' a"
      and "l'labels Γ q"
    shows "p'sterms Γ p. llabels Γ p'. P ((σ, l), a, (σ', l'))"
  by (intro ballI) (rule onll_ostep_invariant_sterms [OF assms])

lemma oseq_step_invariant_ctermI [intro]:
  assumes wf: "wellformed Γ"
      and cw: "control_within Γ (init A)"
      and sl: "simple_labels Γ"
      and sp: "trans A = oseqp_sos Γ i"
      and local: "p l σ a q l' σ' pp. 
                   pcterms Γ;
                   llabels Γ p;
                   ((σ, p), a, (σ', q))  oseqp_sos Γ i;
                   ((σ, p), a, (σ', q))  trans A;
                   l'labels Γ q;
                   (σ, pp)  oreachable A S U;
                   psterms Γ pp;
                   (σ', q)  oreachable A S U;
                   S σ σ' a
                   P ((σ, l), a, (σ', l'))"
    shows "A A (S, U →) onll Γ P"
  proof
       fix σ p l a σ' q l'
    assume sr: "(σ, p)  oreachable A S U"
       and tr: "((σ, p), a, (σ', q))  trans A"
       and "S σ σ' a"
       and pl: "l  labels Γ p"
       and A5: "l'  labels Γ q"
    from this(2) and sp have "((σ, p), a, (σ', q))  oseqp_sos Γ i" by simp
    then obtain p' where "p'  sterms Γ p"
                     and A3: "((σ, p'), a, (σ', q))  oseqp_sos Γ i"
      by (blast dest: otrans_from_sterms [OF _ wf])
    from this(2) and sp have A4: "((σ, p'), a, (σ', q))  trans A" by simp
    from wf cw sp sr p'sterms Γ p have A1: "p'cterms Γ"
      by (rule oseq_reachable_in_cterms)
    from sr p'sterms Γ p
      obtain pp where A6: "(σ, pp)oreachable A S U"
                  and A7: "p'sterms Γ pp"
      by auto
    from sr tr S σ σ' a have A8: "(σ', q)oreachable A S U"
      by - (erule(2) oreachable_local')
    from wf cw sp sr have "pn. p  subterms (Γ pn)"
      by (rule oreachable_subterms)           
    with sl wf have "p'sterms Γ p. l  labels Γ p'"
      using pl by (rule simple_labels_in_sterms)
    with p'  sterms Γ p have "l  labels Γ p'" by simp
    with A1 show "P ((σ, l), a, (σ', l'))" using A3 A4 A5 A6 A7 A8 S σ σ' a
      by (rule local)
  qed

lemma oseq_step_invariant_ctermsI [intro]:
  assumes wf: "wellformed Γ"
      and "control_within Γ (init A)"
      and "simple_labels Γ"
      and "trans A = oseqp_sos Γ i"
      and local: "p l σ a q l' σ' pp pn. 
                   wellformed Γ;
                   pctermsl (Γ pn);
                   not_call p;
                   llabels Γ p;
                   ((σ, p), a, (σ', q))  oseqp_sos Γ i;
                   ((σ, p), a, (σ', q))  trans A;
                   l'labels Γ q;
                   (σ, pp)  oreachable A S U;
                   psterms Γ pp;
                   (σ', q)  oreachable A S U;
                   S σ σ' a
                   P ((σ, l), a, (σ', l'))"
    shows "A A (S, U →) onll Γ P"
  using assms(1-4) proof (rule oseq_step_invariant_ctermI)
    fix p l σ a q l' σ' pp
    assume "p  cterms Γ"
       and otherassms: "l  labels Γ p"
           "((σ, p), a, (σ', q))  oseqp_sos Γ i"
           "((σ, p), a, (σ', q))  trans A"
           "l'  labels Γ q"
           "(σ, pp)  oreachable A S U"
           "p  sterms Γ pp"
           "(σ', q)  oreachable A S U"
           "S σ σ' a"
    from this(1) obtain pn where "p  ctermsl(Γ pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P ((σ, l), a, (σ', l'))"
      using otherassms by (rule local)
 qed

lemma open_seqp_action [elim]:
  assumes "wellformed Γ"
      and "((σ i, p), a, (σ' i, p'))  seqp_sos Γ"
    shows "((σ, p), a, (σ', p'))  oseqp_sos Γ i"
  proof -
    from assms obtain ps where "pssterms Γ p"
                           and "((σ i, ps), a, (σ' i, p'))  seqp_sos Γ"
      by - (drule trans_from_sterms, auto)
    thus ?thesis
    proof (induction p)
      fix p1 p2
      assume " ps  sterms Γ p1; ((σ i, ps), a, σ' i, p')  seqp_sos Γ 
               ((σ, p1), a, (σ', p'))  oseqp_sos Γ i"
         and " ps  sterms Γ p2; ((σ i, ps), a, σ' i, p')  seqp_sos Γ 
               ((σ, p2), a, (σ', p'))  oseqp_sos Γ i"
         and "ps  sterms Γ (p1  p2)"
         and "((σ i, ps), a, (σ' i, p'))  seqp_sos Γ"
      with assms(1) show "((σ, p1  p2), a, (σ', p'))  oseqp_sos Γ i"
        by simp (metis oseqp_sos.ochoiceT1 oseqp_sos.ochoiceT2)
    next
      fix l fip fmsg p1 p2
      assume IH1: " ps  sterms Γ p1; ((σ i, ps), a, σ' i, p')  seqp_sos Γ 
                     ((σ, p1), a, (σ', p'))  oseqp_sos Γ i"
         and IH2: " ps  sterms Γ p2; ((σ i, ps), a, σ' i, p')  seqp_sos Γ 
                     ((σ, p2), a, (σ', p'))  oseqp_sos Γ i"
         and "ps  sterms Γ ({l}unicast(fip, fmsg). p1  p2)"
         and "((σ i, ps), a, (σ' i, p'))  seqp_sos Γ"
      from this(3-4) have "((σ i, {l}unicast(fip, fmsg). p1  p2), a, (σ' i, p'))  seqp_sos Γ"
        by simp
      thus "((σ, {l}unicast(fip, fmsg). p1  p2), a, (σ', p'))  oseqp_sos Γ i"
      proof (rule seqp_unicastTE)
        assume "a = unicast (fip (σ i)) (fmsg (σ i))"
           and "σ' i = σ i"
           and "p' = p1"
        thus ?thesis by auto
      next
        assume "a = ¬unicast (fip (σ i))"
           and "σ' i = σ i"
           and "p' = p2"
        thus ?thesis by auto
      qed
    next
      fix p
      assume "ps  sterms Γ (call(p))"
         and "((σ i, ps), a, (σ' i, p'))  seqp_sos Γ"
      with assms(1) have "((σ, ps), a, (σ', p'))  oseqp_sos Γ i"
        by (cases ps) auto
      with assms(1) ps  sterms Γ (call(p)) have "((σ, Γ p), a, (σ', p'))  oseqp_sos Γ i"
        by - (rule otrans_from_sterms', simp_all)
      thus "((σ, call(p)), a, (σ', p'))  oseqp_sos Γ i" by auto
    qed auto
  qed

end

Theory OAWN_Convert

(*  Title:       OAWN_Convert.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Transfer standard invariants into open invariants"

theory OAWN_Convert
imports AWN_SOS_Labels AWN_Invariants
        OAWN_SOS OAWN_Invariants
begin

definition initiali :: "'i  (('i  'g) × 'l) set  ('g × 'l) set  bool"
where "initiali i OI CI  ({(σ i, p)|σ p. (σ, p)  OI} = CI)"

lemma initialiI [intro]:
  assumes OICI: "σ p. (σ, p)  OI  (σ i, p)  CI"
      and CIOI: "ξ p. (ξ, p)  CI  σ. ξ = σ i  (σ, p)  OI"
    shows "initiali i OI CI"
  unfolding initiali_def
  by (intro set_eqI iffI) (auto elim!: OICI CIOI)

lemma open_from_initialiD [dest]:
  assumes "initiali i OI CI"
      and "(σ, p)  OI"
    shows "ξ. σ i = ξ  (ξ, p)  CI"
  using assms unfolding initiali_def by auto

lemma closed_from_initialiD [dest]:
  assumes "initiali i OI CI"
      and "(ξ, p)  CI"
    shows "σ. σ i = ξ  (σ, p)  OI"
  using assms unfolding initiali_def by auto

definition
  seql :: "'i  (('s × 'l)  bool)  (('i  's) × 'l)  bool"
where
  "seql i P  (λ(σ, p). P (σ i, p))"

lemma seqlI [intro]:
  "P (fst s i, snd s)  seql i P s"
  by (clarsimp simp: seql_def)

lemma same_seql [elim]:
  assumes "j{i}. σ' j = σ j"
      and "seql i P (σ', s)"
    shows "seql i P (σ, s)"
  using assms unfolding seql_def by (clarsimp)

lemma seqlsimp:
  "seql i P (σ, p) = P (σ i, p)"
  unfolding seql_def by simp

lemma other_steps_resp_local [intro!, simp]: "other_steps (other A I) I"
  by (clarsimp elim!: otherE)

lemma seql_onl_swap:
  "seql i (onl Γ P) = onl Γ (seql i P)"
  unfolding seql_def onl_def by simp

lemma oseqp_sos_resp_local_steps [intro!, simp]:
  fixes Γ :: "'p  ('s, 'm, 'p, 'l) seqp"
  shows "local_steps (oseqp_sos Γ i) {i}"
  proof
    fix σ σ' ζ ζ' :: "nat  's" and s a s'
    assume tr: "((σ, s), a, σ', s')  oseqp_sos Γ i"
       and "j{i}. ζ j = σ j"
    thus "ζ'. (j{i}. ζ' j = σ' j)  ((ζ, s), a, (ζ', s'))  oseqp_sos Γ i"
    proof induction
      fix σ σ' l ms p
      assume "σ' i = σ i"
         and "j{i}. ζ j = σ j"
      hence "((ζ, {l}broadcast(ms).p), broadcast (ms (σ i)), (σ', p))  oseqp_sos Γ i"
        by (metis obroadcastT singleton_iff)
      with j{i}. ζ j = σ j show "ζ'. (j{i}. ζ' j = σ' j) 
            ((ζ, {l}broadcast(ms).p), broadcast (ms (σ i)), (ζ', p))  oseqp_sos Γ i"
        by blast
    next
      fix σ σ' :: "nat  's" and fmsg :: "'m  's  's" and msg l p
      assume *:  "σ' i = fmsg msg (σ i)"
         and **: "j{i}. ζ j = σ j"
      hence "j{i}. (ζ(i := fmsg msg (ζ i))) j = σ' j" by clarsimp
      moreover from * **
        have "((ζ, {l}receive(fmsg).p), receive msg, (ζ(i := fmsg msg (ζ i)), p))  oseqp_sos Γ i"
        by (metis fun_upd_same oreceiveT)
      ultimately show "ζ'. (j{i}. ζ' j = σ' j) 
                            ((ζ, {l}receive(fmsg).p), receive msg, (ζ', p))  oseqp_sos Γ i"
        by blast
    next
      fix σ' σ l p and fas :: "'s  's"
      assume *:  "σ' i = fas (σ i)"
         and **: "j{i}. ζ j = σ j"
      hence "j{i}. (ζ(i := fas (ζ i))) j = σ' j" by clarsimp
      moreover from * ** have "((ζ, {l}fas p), τ, (ζ(i := fas (ζ i)), p))  oseqp_sos Γ i"
        by (metis fun_upd_same oassignT)
      ultimately show "ζ'. (j{i}. ζ' j = σ' j)  ((ζ, {l}fas p), τ, (ζ', p))  oseqp_sos Γ i"
        by blast
    next
      fix g :: "'s  's set" and σ σ' l p
      assume *:  "σ' i  g (σ i)"
         and **: "j{i}. ζ j = σ j"
      hence "j{i}. (SOME ζ'. ζ' i = σ' i) j = σ' j" by simp (metis (lifting, full_types) some_eq_ex)
      moreover with * ** have "((ζ, {l}g p), τ, (SOME ζ'. ζ' i = σ' i, p))  oseqp_sos Γ i"
        by simp (metis oguardT step_seq_tau)
      ultimately show "ζ'. (j{i}. ζ' j = σ' j)  ((ζ, {l}g p), τ, (ζ', p))  oseqp_sos Γ i"
        by blast
    next
      fix σ pn a σ' p'
      assume "((σ, Γ pn), a, (σ', p'))  oseqp_sos Γ i"
         and IH: "j{i}. ζ j = σ j  ζ'. (j{i}. ζ' j = σ' j)  ((ζ, Γ pn), a, (ζ', p'))  oseqp_sos Γ i"
         and "j{i}. ζ j = σ j"
      then obtain ζ' where "j{i}. ζ' j = σ' j"
                       and "((ζ, Γ pn), a, (ζ', p'))  oseqp_sos Γ i"
        by blast
      thus "ζ'. (j{i}. ζ' j = σ' j)  ((ζ, call(pn)), a, (ζ', p'))  oseqp_sos Γ i"
        by blast
    next
      fix σ p a σ' p' q
      assume "((σ, p), a, (σ', p'))  oseqp_sos Γ i"
         and "j{i}. ζ j = σ j  ζ'. (j{i}. ζ' j = σ' j)  ((ζ, p), a, (ζ', p'))  oseqp_sos Γ i"
         and "j{i}. ζ j = σ j"
      then obtain ζ' where "j{i}. ζ' j = σ' j"
                       and "((ζ, p), a, (ζ', p'))  oseqp_sos Γ i"
        by blast
      thus "ζ'. (j{i}. ζ' j = σ' j)  ((ζ, p  q), a, (ζ', p'))  oseqp_sos Γ i"
        by blast
    next
      fix σ p a σ' q q'
      assume "((σ, q), a, (σ', q'))  oseqp_sos Γ i"
         and "j{i}. ζ j = σ j  ζ'. (j{i}. ζ' j = σ' j)  ((ζ, q), a, (ζ', q'))  oseqp_sos Γ i"
         and "j{i}. ζ j = σ j"
      then obtain ζ' where "j{i}. ζ' j = σ' j"
                       and "((ζ, q), a, (ζ', q'))  oseqp_sos Γ i"
        by blast
      thus "ζ'. (j{i}. ζ' j = σ' j)  ((ζ, p  q), a, (ζ', q'))  oseqp_sos Γ i"
        by blast
    qed (simp_all, (metis ogroupcastT ounicastT onotunicastT osendT odeliverT)+)
  qed

lemma oseqp_sos_subreachable [intro!, simp]:
  assumes "trans OA = oseqp_sos Γ i"
    shows "subreachable OA (other ANY {i}) {i}"
  by rule (clarsimp simp add: assms(1))+

lemma oseq_step_is_seq_step:
    fixes σ :: "ip  's"
  assumes "((σ, p), a :: 'm seq_action, (σ', p'))  oseqp_sos Γ i"
      and "σ i = ξ"
    shows "ξ'. σ' i = ξ'  ((ξ, p), a, (ξ', p'))  seqp_sos Γ"
  using assms proof induction
    fix σ σ' l ms p
    assume "σ' i = σ i"
       and "σ i = ξ"
    hence "σ' i = ξ" by simp
    have "((ξ, {l}broadcast(ms).p), broadcast (ms ξ), (ξ, p))  seqp_sos Γ"
      by auto
    with σ i = ξ and σ' i = ξ show "ξ'. σ' i = ξ'
              ((ξ, {l}broadcast(ms).p), broadcast (ms (σ i)), (ξ', p))  seqp_sos Γ"
       by clarsimp
  next
    fix fmsg :: "'m  's  's" and msg :: 'm and σ' σ l p
    assume "σ' i = fmsg msg (σ i)"
       and "σ i = ξ"
    have "((ξ, {l}receive(fmsg).p), receive msg, (fmsg msg ξ, p))  seqp_sos Γ"
      by auto
    with σ' i = fmsg msg (σ i) and σ i = ξ
      show "ξ'. σ' i = ξ'  ((ξ, {l}receive(fmsg).p), receive msg, (ξ', p))  seqp_sos Γ"
         by clarsimp
  qed (simp_all, (metis assignT choiceT1 choiceT2 groupcastT guardT
                        callT unicastT notunicastT sendT deliverT step_seq_tau)+)

lemma reachable_oseq_seqp_sos:
  assumes "(σ, p)  reachable OA I"
      and "initiali i (init OA) (init A)"
      and spo: "trans OA = oseqp_sos Γ i"
      and sp: "trans A = seqp_sos Γ"
      shows "ξ. σ i = ξ  (ξ, p)  reachable A I"
  using assms(1) proof (induction rule: reachable_pair_induct)
    fix σ p
    assume "(σ, p)  init OA"
    with ‹initiali i (init OA) (init A) obtain ξ where "σ i = ξ"
                                                    and "(ξ, p)  init A"
      by auto
    from (ξ, p)  init A have "(ξ, p)  reachable A I" ..
    with σ i = ξ show "ξ. σ i = ξ  (ξ, p)  reachable A I"
      by auto
  next
    fix σ p σ' p' a
    assume "(σ, p)  reachable OA I"
       and IH: "ξ. σ i = ξ  (ξ, p)  reachable A I"
       and otr: "((σ, p), a, (σ', p'))  trans OA"
       and "I a"
    from IH obtain ξ where "σ i = ξ"
                       and cr: "(ξ, p)  reachable A I"
      by clarsimp
    from otr and spo have "((σ, p), a, (σ', p'))  oseqp_sos Γ i" by simp
    with σ i = ξ obtain ξ' where "σ' i = ξ'"
                               and "((ξ, p), a, (ξ', p'))  seqp_sos Γ"
        by (auto dest!: oseq_step_is_seq_step)
    from this(2) and sp have ctr: "((ξ, p), a, (ξ', p'))  trans A" by simp
    from (ξ, p)  reachable A I and ctr and I a
      have "(ξ', p')  reachable A I" ..
    with σ' i = ξ' show "ξ. σ' i = ξ  (ξ, p')  reachable A I"
      by blast
  qed

lemma reachable_oseq_seqp_sos':
  assumes "s  reachable OA I"
      and "initiali i (init OA) (init A)"
      and "trans OA = oseqp_sos Γ i"
      and "trans A = seqp_sos Γ"
    shows "ξ. (fst s) i = ξ  (ξ, snd s)  reachable A I"
  using assms
  by - (cases s, auto dest: reachable_oseq_seqp_sos)

text ‹
  Any invariant shown in the (simpler) closed semantics can be transferred to an invariant in
  the open semantics.
›

theorem open_seq_invariant [intro]:
  assumes "A  (I →) P"
      and "initiali i (init OA) (init A)"
      and spo: "trans OA = oseqp_sos Γ i"
      and sp: "trans A = seqp_sos Γ"
    shows "OA  (act I, other ANY {i} →) (seql i P)"
  proof -
    have "OA  (I →) (seql i P)"
      proof (rule invariant_arbitraryI)
        fix s                                      
        assume "s  reachable OA I"
        with ‹initiali i (init OA) (init A) obtain ξ where "(fst s) i = ξ"
                                                        and "(ξ, snd s)  reachable A I"
          by (auto dest: reachable_oseq_seqp_sos' [OF _ _ spo sp])
        with A  (I →) P have "P (ξ, snd s)" by auto
        with (fst s) i = ξ show "seql i P s" by auto
      qed
    moreover from spo have "subreachable OA (other ANY {i}) {i}" ..
    ultimately show ?thesis
    proof (rule open_closed_invariant)
      fix σ σ' s
      assume "j{i}. σ' j = σ j"
         and "seql i P (σ', s)"
      thus "seql i P (σ, s)" ..
    qed
  qed

definition
  seqll :: "'i  ((('s × 'l) × 'a × ('s × 'l))  bool)
                ((('i  's) × 'l) × 'a × (('i  's) × 'l))  bool"
where
  "seqll i P  (λ((σ, p), a, (σ', p')). P ((σ i, p), a, (σ' i, p')))"

lemma same_seqll [elim]:
  assumes "j{i}. σ1' j = σ1 j"
      and "j{i}. σ2' j = σ2 j"
      and "seqll i P ((σ1', s), a, (σ2', s'))"
    shows "seqll i P ((σ1,  s), a, (σ2,  s'))"
  using assms unfolding seqll_def by (clarsimp)

lemma seqllI [intro!]:
  assumes "P ((σ i, p), a, (σ' i, p'))"
    shows "seqll i P ((σ, p), a, (σ', p'))"
  using assms unfolding seqll_def by simp

lemma seqllD [dest]:
  assumes "seqll i P ((σ, p), a, (σ', p'))"
    shows "P ((σ i, p), a, (σ' i, p'))"
  using assms unfolding seqll_def by simp

lemma seqllsimp:
  "seqll i P ((σ, p), a, (σ', p')) = P ((σ i, p), a, (σ' i, p'))"
  unfolding seqll_def by simp

lemma seqll_onll_swap:
  "seqll i (onll Γ P) = onll Γ (seqll i P)"
  unfolding seqll_def onll_def by simp

theorem open_seq_step_invariant [intro]:
  assumes "A A (I →) P"
      and "initiali i (init OA) (init A)"
      and spo: "trans OA = oseqp_sos Γ i"
      and sp: "trans A = seqp_sos Γ"
    shows "OA A (act I, other ANY {i} →) (seqll i P)"
  proof -
    have "OA A (I →) (seqll i P)"
    proof (rule step_invariant_arbitraryI)
      fix σ p a σ' p'
      assume or: "(σ, p)  reachable OA I"
         and otr: "((σ, p), a, (σ', p'))  trans OA"
         and "I a"
      from or ‹initiali i (init OA) (init A) spo sp obtain ξ where "σ i = ξ"
                                                             and cr: "(ξ, p)  reachable A I"
        by - (drule(3) reachable_oseq_seqp_sos', auto)
      from otr and spo have "((σ, p), a, (σ', p'))  oseqp_sos Γ i" by simp
      with σ i = ξ obtain ξ' where "σ' i = ξ'"
                                 and ctr: "((ξ, p), a, (ξ', p'))  seqp_sos Γ"
        by (auto dest!: oseq_step_is_seq_step)
      with sp have "((ξ, p), a, (ξ', p'))  trans A" by simp
      with A A (I →) P cr have "P ((ξ, p), a, (ξ', p'))" using I a ..
      with σ i = ξ and σ' i = ξ' have "P ((σ i, p), a, (σ' i, p'))" by simp
      thus "seqll i P ((σ, p), a, (σ', p'))" ..
    qed
    moreover from spo have "local_steps (trans OA) {i}" by simp
    moreover have "other_steps (other ANY {i}) {i}" ..
    ultimately show ?thesis
    proof (rule open_closed_step_invariant)
      fix σ ζ a σ' ζ' s s'
      assume "j{i}. σ j = ζ j"
         and "j{i}. σ' j = ζ' j"
         and "seqll i P ((σ, s), a, (σ', s'))"
        thus "seqll i P ((ζ, s), a, (ζ', s'))" ..
    qed
  qed

end

Theory Qmsg

(*  Title:       Qmsg.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Model the standard queuing model"

theory Qmsg
imports AWN_SOS_Labels AWN_Invariants
begin

text ‹Define the queue process›

fun ΓQMSG :: "('m list, 'm, unit, unit label) seqp_env"
where
  "ΓQMSG () = labelled () (receive(λmsg msgs. msgs @ [msg]). call(())
            msgs. msgs  []
               (send(λmsgs. hd msgs).
                 (msgs. tl msgs call(())
                   receive(λmsg msgs. tl msgs @ [msg]). call(()))
               receive(λmsg msgs. msgs @ [msg]). call(())))"

definition σQMSG :: "(('m::msg) list × ('m list, 'm, unit, unit label) seqp) set"
where "σQMSG  {([], ΓQMSG ())}"

abbreviation qmsg
  :: "(('m::msg) list × ('m list, 'm, unit, unit label) seqp, 'm seq_action) automaton"
where
  "qmsg   init = σQMSG, trans = seqp_sos ΓQMSG "

declare ΓQMSG.simps [simp del, code del]
lemmas ΓQMSG_simps [simp, code] = ΓQMSG.simps [simplified]

lemma σQMSG_not_empty [simp, intro]: QMSG  {}"
  unfolding σQMSG_def by simp

lemma σQMSG_exists [simp]: "qmsg q. (qmsg, q)  σQMSG"
  unfolding σQMSG_def by simp

lemma qmsg_wf [simp]: "wellformed ΓQMSG"
  by (rule wf_no_direct_calls) auto

lemmas qmsg_labels_not_empty [simp] = labels_not_empty [OF qmsg_wf]

lemma qmsg_control_within [simp]: "control_within ΓQMSG (init qmsg)"
  unfolding σQMSG_def by (rule control_withinI) (auto simp del: ΓQMSG_simps)

lemma qmsg_simple_labels [simp]: "simple_labels ΓQMSG"
  unfolding simple_labels_def by auto

lemma qmsg_trans: "trans qmsg = seqp_sos ΓQMSG"
  by simp

lemma σQMSG_labels [simp]: "(ξ, q)  σQMSG   labels ΓQMSG q = {()-:0}"
  unfolding σQMSG_def by simp

lemma qmsg_proc_cases [dest]:
  fixes p pn
  shows "p  ctermsl (ΓQMSG pn)  p  ctermsl (ΓQMSG ())"
  by simp

declare
  ΓQMSG_simps [cterms_env]
  qmsg_proc_cases [ctermsl_cases]
  seq_invariant_ctermsI [OF qmsg_wf qmsg_control_within qmsg_simple_labels qmsg_trans, cterms_intros]
  seq_step_invariant_ctermsI [OF qmsg_wf qmsg_control_within qmsg_simple_labels qmsg_trans, cterms_intros]

end

Theory Qmsg_Lifting

(*  Title:       Qmsg_Lifting.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lifting rules for parallel compositions with QMSG"

theory Qmsg_Lifting
imports Qmsg OAWN_SOS Inv_Cterms OAWN_Invariants
begin

lemma oseq_no_change_on_send:
  fixes σ s a σ' s'
  assumes "((σ, s), a, (σ', s'))  oseqp_sos Γ i"
  shows "case a of
           broadcast m      σ' i = σ i
         | groupcast ips m  σ' i = σ i
         | unicast ips m    σ' i = σ i
         | ¬unicast ips     σ' i = σ i
         | send m           σ' i = σ i
         | deliver m        σ' i = σ i
         | _  True"
  using assms by induction simp_all

lemma qmsg_no_change_on_send_or_receive:
    fixes σ s a σ' s'
  assumes "((σ, s), a, (σ', s'))  oparp_sos i (oseqp_sos Γ i) (seqp_sos ΓQMSG)"
      and "a  τ"
    shows "σ' i = σ i"
  proof -
    from assms(1) obtain p q p' q'
      where "((σ, (p, q)), a, (σ', (p', q')))  oparp_sos i (oseqp_sos Γ i) (seqp_sos ΓQMSG)"
      by (cases s, cases s', simp)
    thus ?thesis
    proof
      assume "((σ, p), a, (σ', p'))  oseqp_sos Γ i"
         and "m. a  receive m"
      with a  τ show "σ' i = σ i"
        by - (drule oseq_no_change_on_send, cases a, auto)
    next
      assume "(q, a, q')  seqp_sos ΓQMSG"
         and "σ' i = σ i"
        thus "σ' i = σ i" by simp
    next
      assume "a = τ" with a  τ show ?thesis by auto
    qed
  qed

lemma qmsg_msgs_not_empty:
  "qmsg  onl ΓQMSG (λ(msgs, l). l = ()-:1  msgs  [])"
  by inv_cterms

lemma qmsg_send_from_queue:
  "qmsg A (λ((msgs, q), a, _). sendmsg (λm. mset msgs) a)"
  proof -
    have "qmsg A onll ΓQMSG (λ((msgs, _), a, _). sendmsg (λm. mset msgs) a)"
      by (inv_cterms inv add: onl_invariant_sterms [OF qmsg_wf qmsg_msgs_not_empty])
    thus ?thesis
      by (rule step_invariant_weakenE) (auto dest!: onllD)
  qed

lemma qmsg_queue_contents:
  "qmsg A (λ((msgs, q), a, (msgs', q')). case a of
                                             receive m  set msgs'  set (msgs @ [m])
                                           | _  set msgs'  set msgs)"
  proof -
    have "qmsg A onll ΓQMSG (λ((msgs, q), a, (msgs', q')).
                                     case a of
                                       receive m  set msgs'  set (msgs @ [m])
                                     | _  set msgs'  set msgs)"
      by (inv_cterms) (clarsimp simp add: in_set_tl)+
    thus ?thesis
      by (rule step_invariant_weakenE) (auto dest!: onllD)
  qed

lemma qmsg_send_receive_or_tau:
  "qmsg A (λ(_, a, _). m. a = send m  a = receive m  a = τ)"
  proof -
   have "qmsg A onll ΓQMSG (λ(_, a, _). m. a = send m  a = receive m  a = τ)"
     by inv_cterms
   thus ?thesis
    by rule (auto dest!: onllD)
  qed

lemma par_qmsg_oreachable:
  assumes "(σ, ζ)  oreachable (A ⟨⟨i qmsg) (otherwith S {i} (orecvmsg R)) (other U {i})"
           (is "_  oreachable _ ?owS _")
      and pinv: "A A (otherwith S {i} (orecvmsg R), other U {i} →)
                       globala (λ(σ, _, σ'). U (σ i) (σ' i))"
      and ustutter: "ξ. U ξ ξ"
      and sgivesu: "ξ ξ'. S ξ ξ'  U ξ ξ'"
      and upreservesq: "σ σ' m.  j. U (σ j) (σ' j); R σ m   R σ' m"
  shows "(σ, fst ζ)  oreachable A ?owS (other U {i})
          snd ζ  reachable qmsg (recvmsg (R σ))
          (mset (fst (snd ζ)). R σ m)"
  using assms(1) proof (induction rule: oreachable_pair_induct)
    fix σ pq
    assume "(σ, pq)  init (A ⟨⟨i qmsg)"
    then obtain p ms q where "pq = (p, (ms, q))"
                         and "(σ, p)  init A"
                         and "(ms, q)  init qmsg"
      by (clarsimp simp del: ΓQMSG_simps)
    from this(2) have "(σ, p)  oreachable A ?owS (other U {i})" ..
    moreover from (ms, q)  init qmsg› have "(ms, q)  reachable qmsg (recvmsg (R σ))" ..
    moreover from (ms, q)  init qmsg› have "ms = []"
        unfolding σQMSG_def by simp
    ultimately show "(σ, fst pq)  oreachable A ?owS (other U {i})
                      snd pq  reachable qmsg (recvmsg (R σ))
                      (mset (fst (snd pq)). R σ m)"
      using pq = (p, (ms, q)) by simp
  next
    note ΓQMSG_simps [simp del]
    case (other σ pq σ')
    hence "(σ, fst pq)  oreachable A ?owS (other U {i})"
      and "other U {i} σ σ'"
      and qr: "snd pq  reachable qmsg (recvmsg (R σ))"
      and "mset (fst (snd pq)). R σ m"
      by simp_all
    from ‹other U {i} σ σ' and ustutter have "j. U (σ j) (σ' j)"
        by (clarsimp elim!: otherE) metis
    from ‹other U {i} σ σ'
     and (σ, fst pq)  oreachable A ?owS (other U {i})
      have "(σ', fst pq)  oreachable A ?owS (other U {i})"
        by - (rule oreachable_other')
    moreover have "mset (fst (snd pq)). R σ' m"
    proof
      fix m assume "m  set (fst (snd pq))"
      with mset (fst (snd pq)). R σ m have "R σ m" ..
      with j. U (σ j) (σ' j) show "R σ' m" by (rule upreservesq)
    qed
    moreover from qr have "snd pq  reachable qmsg (recvmsg (R σ'))"
    proof
      fix a
      assume "recvmsg (R σ) a"
      thus "recvmsg (R σ') a"
      proof (rule recvmsgE [where R=R])
        fix m assume "R σ m"
        with j. U (σ j) (σ' j) show "R σ' m" by (rule upreservesq)
      qed
    qed
    ultimately show ?case using qr by simp
  next
    case (local σ pq σ' pq' a)
    obtain p ms q p' ms' q' where "pq = (p, (ms, q))"
                              and "pq' = (p', (ms', q'))"
      by (cases pq, cases pq') metis
    with local.hyps local.IH
      have pqtr: "((σ, (p, (ms, q))), a, (σ', (p', (ms', q'))))
                     oparp_sos i (trans A) (seqp_sos ΓQMSG)"
        and por: "(σ, p)  oreachable A ?owS (other U {i})"
        and qr: "(ms, q)  reachable qmsg (recvmsg (R σ))"
        and "mset ms. R σ m"
        and "?owS σ σ' a"
      by (simp_all del: ΓQMSG_simps)

    from ?owS σ σ' a have "j. ji  S (σ j) (σ' j)"
      by (clarsimp dest!: otherwith_syncD)
    with sgivesu have "j. ji  U (σ j) (σ' j)" by simp

    from ?owS σ σ' a have "orecvmsg R σ a" by (rule otherwithE)
    hence "recvmsg (R σ) a" ..

    from pqtr have "(σ', p')  oreachable A ?owS (other U {i})
                   (ms', q')  reachable qmsg (recvmsg (R σ'))
                   (mset ms'. R σ' m)"
    proof
      assume "((σ, p), a, (σ', p'))  trans A"
         and "m. a  receive m"
         and "(ms', q') = (ms, q)"
      from this(1) have ptr: "((σ, p), a, (σ', p'))  trans A" by simp
      with pinv por and ?owS σ σ' a have "U (σ i) (σ' i)"
        by (auto dest!: ostep_invariantD)
      with j. ji  U (σ j) (σ' j) have "j. U (σ j) (σ' j)" by auto

      hence recvmsg': "a. recvmsg (R σ) a  recvmsg (R σ') a"
        by (auto elim!: recvmsgE [where R=R] upreservesq)

      from por ptr ?owS σ σ' a have "(σ', p')  oreachable A ?owS (other U {i})"
        by - (rule oreachable_local')

      moreover have "(ms', q')  reachable qmsg (recvmsg (R σ'))"
      proof -
        from qr and (ms', q') = (ms, q)
          have "(ms', q')  reachable qmsg (recvmsg (R σ))" by simp
        thus ?thesis by (rule reachable_weakenE) (erule recvmsg')
      qed

      moreover have "mset ms'. R σ' m"
      proof
        fix m
        assume "mset ms'"
        with (ms', q') = (ms, q) have "mset ms" by simp
        with mset ms. R σ m have "R σ m" ..
        with j. U (σ j) (σ' j) show "R σ' m"
          by (rule upreservesq)
      qed

      ultimately show
        "(σ', p')  oreachable A ?owS (other U {i})
           (ms', q')  reachable qmsg (recvmsg (R σ'))
           (mset ms'. R σ' m)" by simp_all
    next
      assume qtr: "((ms, q), a, (ms', q'))  seqp_sos ΓQMSG"
         and "m. a  send m"
         and "p' = p"
         and "σ' i = σ i"

      from this(4) and ξ. U ξ ξ have "U (σ i) (σ' i)" by simp
      with j. ji  U (σ j) (σ' j) have "j. U (σ j) (σ' j)" by auto

      hence recvmsg': "a. recvmsg (R σ) a  recvmsg (R σ') a"
        by (auto elim!: recvmsgE [where R=R] upreservesq)

      from qtr have tqtr: "((ms, q), a, (ms', q'))  trans qmsg" by simp

      from j. U (σ j) (σ' j) and  σ' i = σ i have "other U {i} σ σ'" by auto
      with por and p' = p
        have "(σ', p')  oreachable A ?owS (other U {i})"
          by (auto dest: oreachable_other)

      moreover have "(ms', q')  reachable qmsg (recvmsg (R σ'))"
      proof (rule reachable_weakenE [where P="recvmsg (R σ)"])
        from qr tqtr ‹recvmsg (R σ) a show "(ms', q')  reachable qmsg (recvmsg (R σ))" ..
      qed (rule recvmsg')

      moreover have "mset ms'. R σ' m"
      proof
        fix m
        assume "m  set ms'"
        moreover have "case a of receive m  set ms'  set (ms @ [m]) | _  set ms'  set ms"
          proof -
            from qr have "(ms, q)  reachable qmsg TT" ..
            thus ?thesis using tqtr
              by (auto dest!: step_invariantD [OF qmsg_queue_contents])
          qed
        ultimately have "R σ m" using mset ms. R σ m and ‹orecvmsg R σ a 
          by (cases a) auto
        with j. U (σ j) (σ' j) show "R σ' m"
          by (rule upreservesq)
      qed

      ultimately show "(σ', p')  oreachable A ?owS (other U {i})
                      (ms', q')  reachable qmsg (recvmsg (R σ'))
                      (mset ms'. R σ' m)" by simp
    next
      fix m
      assume "a = τ"
         and "((σ, p), receive m, (σ', p'))  trans A"
         and "((ms, q), send m, (ms', q'))  seqp_sos ΓQMSG"
      from this(2-3)
        have ptr: "((σ, p), receive m, (σ', p'))  trans A"
         and qtr: "((ms, q), send m, (ms', q'))  trans qmsg" by simp_all

      from qr have "(ms, q)  reachable qmsg TT" ..
      with qtr have "m  set ms"
        by (auto dest!: step_invariantD [OF qmsg_send_from_queue])
      with mset ms. R σ m have "R σ m" ..
      hence "orecvmsg R σ (receive m)" by simp

      with j. ji  S (σ j) (σ' j) have "?owS σ σ' (receive m)"
        by (auto intro!: otherwithI)
      with pinv por ptr have "U (σ i) (σ' i)"
        by (auto dest!: ostep_invariantD)
      with j. ji  U (σ j) (σ' j) have "j. U (σ j) (σ' j)" by auto
      hence recvmsg': "a. recvmsg (R σ) a  recvmsg (R σ') a"
        by (auto elim!: recvmsgE [where R=R] upreservesq)

      from por ptr have "(σ', p')  oreachable A ?owS (other U {i})"
        using ?owS σ σ' (receive m) by - (erule(1) oreachable_local, simp)

      moreover have "(ms', q')  reachable qmsg (recvmsg (R σ'))"
      proof (rule reachable_weakenE [where P="recvmsg (R σ)"])
        have "recvmsg (R σ) (send m)" by simp
        with qr qtr show "(ms', q')  reachable qmsg (recvmsg (R σ))" ..
      qed (rule recvmsg')

      moreover have "mset ms'. R σ' m"
      proof
        fix m
        assume "m  set ms'"
        moreover have "set ms'  set ms"
          proof -
            from qr have "(ms, q)  reachable qmsg TT" ..
            thus ?thesis using qtr
              by (auto dest!: step_invariantD [OF qmsg_queue_contents])
          qed
        ultimately have "R σ m" using mset ms. R σ m by auto
        with j. U (σ j) (σ' j) show "R σ' m"
          by (rule upreservesq)
      qed

      ultimately show "(σ', p')  oreachable A ?owS (other U {i})
                      (ms', q')  reachable qmsg (recvmsg (R σ'))
                      (mset ms'. R σ' m)" by simp
    qed
    with pq = (p, (ms, q)) and pq' = (p', (ms', q')) show ?case
      by (simp_all del: ΓQMSG_simps)
  qed

lemma par_qmsg_oreachable_statelessassm:
  assumes "(σ, ζ)  oreachable (A ⟨⟨i qmsg)
                               (λσ _. orecvmsg (λ_. R) σ) (other (λ_ _. True) {i})"
      and ustutter: "ξ. U ξ ξ"
  shows "(σ, fst ζ)  oreachable A (λσ _. orecvmsg (λ_. R) σ) (other (λ_ _. True) {i})
          snd ζ  reachable qmsg (recvmsg R)
          (mset (fst (snd ζ)). R m)"
  proof -
    from assms(1)
      have "(σ, ζ)  oreachable (A ⟨⟨i qmsg)
                                (otherwith (λ_ _. True) {i} (orecvmsg (λ_. R)))
                                (other (λ_ _. True) {i})" by auto
    moreover
      have "A A (otherwith (λ_ _. True) {i} (orecvmsg (λ_. R)),
                  other (λ_ _. True) {i} →) globala (λ(σ, _, σ'). True)"
        by auto
    ultimately
      obtain "(σ, fst ζ)  oreachable A
                           (otherwith (λ_ _. True) {i} (orecvmsg (λ_. R))) (other (λ_ _. True) {i})"
         and  *: "snd ζ  reachable qmsg (recvmsg R)"
         and **: "(mset (fst (snd ζ)). R m)"
        by (auto dest!: par_qmsg_oreachable)
    from this(1)
      have "(σ, fst ζ)  oreachable A (λσ _. orecvmsg (λ_. R) σ) (other (λ_ _. True) {i})"
        by rule auto
    thus ?thesis using * ** by simp
  qed

lemma lift_into_qmsg:
  assumes "A  (otherwith S {i} (orecvmsg R), other U {i} →) global P"
      and "ξ. U ξ ξ"
      and "ξ ξ'. S ξ ξ'  U ξ ξ'"
      and "σ σ' m.  j. U (σ j) (σ' j); R σ m   R σ' m"
      and "A A (otherwith S {i} (orecvmsg R), other U {i} →)
                 globala (λ(σ, _, σ'). U (σ i) (σ' i))"
    shows "A ⟨⟨i qmsg  (otherwith S {i} (orecvmsg R), other U {i} →) global P"
  proof (rule oinvariant_oreachableI)
    fix σ ζ
    assume "(σ, ζ)  oreachable (A ⟨⟨i qmsg) (otherwith S {i} (orecvmsg R)) (other U {i})"
    then obtain s where "(σ, s)  oreachable A (otherwith S {i} (orecvmsg R)) (other U {i})"
      by (auto dest!: par_qmsg_oreachable [OF _ assms(5,2-4)])
    with assms(1) show "global P (σ, ζ)"
      by (auto dest: oinvariant_weakenD [OF assms(1)])
  qed

lemma lift_step_into_qmsg:
  assumes inv: "A A (otherwith S {i} (orecvmsg R), other U {i} →) globala P"
      and ustutter: "ξ. U ξ ξ"
      and sgivesu: "ξ ξ'. S ξ ξ'  U ξ ξ'"
      and upreservesq: "σ σ' m.  j. U (σ j) (σ' j); R σ m   R σ' m"
      and self_sync: "A A (otherwith S {i} (orecvmsg R), other U {i} →)
                            globala (λ(σ, _, σ'). U (σ i) (σ' i))"

      and recv_stutter:  "σ σ' m.  j. U (σ j) (σ' j); σ' i = σ i   P (σ, receive m, σ')"
      and receive_right: "σ σ' m.  P (σ, receive m, σ')  P (σ, τ, σ')"
    shows "A ⟨⟨i qmsg A (otherwith S {i} (orecvmsg R), other U {i} →) globala P"
      (is "_ A (?owS, ?U →) _")
  proof (rule ostep_invariantI)
    fix σ ζ a σ' ζ'
    assume or: "(σ, ζ)  oreachable (A ⟨⟨i qmsg) ?owS ?U"
       and otr: "((σ, ζ), a, (σ', ζ'))  trans (A ⟨⟨i qmsg)"
       and "?owS σ σ' a"
    from this(2) have "((σ, ζ), a, (σ', ζ'))  oparp_sos i (trans A) (seqp_sos ΓQMSG)"
        by simp
    then obtain s msgs q s' msgs' q'
      where "ζ = (s, (msgs, q))" "ζ' = (s', (msgs', q'))"
        and "((σ, (s, (msgs, q))), a, (σ', (s', (msgs', q'))))
                oparp_sos i (trans A) (seqp_sos ΓQMSG)"
        by (metis prod_cases3)
    from this(1-2) and or
      obtain "(σ, s)  oreachable A ?owS ?U"
             "(msgs, q)  reachable qmsg (recvmsg (R σ))"
             "(mset msgs. R σ m)"
       by (auto dest: par_qmsg_oreachable [OF _ self_sync ustutter sgivesu]
                elim!: upreservesq)
    from otr ζ = (s, (msgs, q)) ζ' = (s', (msgs', q'))
      have "((σ, (s, (msgs, q))), a, (σ', (s', (msgs', q'))))
               oparp_sos i (trans A) (seqp_sos ΓQMSG)"
        by simp
    hence "globala P ((σ, s), a, (σ', s'))"
    proof
      assume "((σ, s), a, (σ', s'))  trans A"
      with (σ, s)  oreachable A ?owS ?U
        show "globala P ((σ, s), a, (σ', s'))"
          using ?owS σ σ' a by (rule ostep_invariantD [OF inv])
    next
      assume "((msgs, q), a, (msgs', q'))  seqp_sos ΓQMSG"
         and "m. a  send m"
         and "σ' i = σ i"
      from this(3) and ustutter have "U (σ i) (σ' i)" by simp
      with ?owS σ σ' a and sgivesu have "j. U (σ j) (σ' j)"
        by (clarsimp dest!: otherwith_syncD) metis
      moreover have "(m. a = receive m)  (a = τ)"
      proof -
        from (msgs, q)  reachable qmsg (recvmsg (R σ))
          have "(msgs, q)  reachable qmsg TT" ..
        moreover from ((msgs, q), a, (msgs', q'))  seqp_sos ΓQMSG
          have "((msgs, q), a, (msgs', q'))  trans qmsg" by simp
        ultimately show ?thesis
          using m. a  send m
          by (auto dest!: step_invariantD [OF qmsg_send_receive_or_tau])
      qed
      ultimately show "globala P ((σ, s), a, (σ', s'))"
        using σ' i = σ i
        by simp (metis receive_right recv_stutter step_seq_tau)
    next
      fix m
      assume "a = τ"
         and "((σ, s), receive m, (σ', s'))  trans A"
         and "((msgs, q), send m, (msgs', q'))  seqp_sos ΓQMSG"

      from (msgs, q)  reachable qmsg (recvmsg (R σ))
        have "(msgs, q)  reachable qmsg TT" ..
      moreover from ((msgs, q), send m, (msgs', q'))  seqp_sos ΓQMSG
        have "((msgs, q), send m, (msgs', q'))  trans qmsg" by simp
      ultimately have "mset msgs"
        by (auto dest!: step_invariantD [OF qmsg_send_from_queue])

      with mset msgs. R σ m have "R σ m" ..
      with ?owS σ σ' a have "?owS σ σ' (receive m)"
          by (auto dest!: otherwith_syncD)

      with ((σ, s), receive m, (σ', s'))  trans A
        have "globala P ((σ, s), receive m, (σ', s'))"
          using (σ, s)  oreachable A ?owS ?U
          by - (rule ostep_invariantD [OF inv])
      hence "P (σ, receive m, σ')" by simp
      hence "P (σ, τ, σ')" by (rule receive_right)
      with a = τ show "globala P ((σ, s), a, (σ', s'))" by simp
    qed
    with ζ = (s, (msgs, q)) and ζ' = (s', (msgs', q')) show "globala P ((σ, ζ), a, (σ', ζ'))"
      by simp
  qed

lemma lift_step_into_qmsg_statelessassm:
  assumes "A A (λσ _. orecvmsg (λ_. R) σ, other (λ_ _. True) {i} →) globala P"
      and "σ σ' m. σ' i = σ i  P (σ, receive m, σ')"
      and "σ σ' m. P (σ, receive m, σ')  P (σ, τ, σ')"
    shows "A ⟨⟨i qmsg A (λσ _. orecvmsg (λ_. R) σ, other (λ_ _. True) {i} →) globala P"
  proof -
    from assms(1) have *: "A A (otherwith (λ_ _. True) {i} (orecvmsg (λ_. R)),
                                 other (λ_ _. True) {i} →) globala P"
      by rule auto
    hence "A ⟨⟨i qmsg A
              (otherwith (λ_ _. True) {i} (orecvmsg (λ_. R)), other (λ_ _. True) {i} →) globala P"
      by (rule lift_step_into_qmsg)
         (auto elim!: assms(2-3) simp del: step_seq_tau)
    thus ?thesis by rule auto
  qed

end

Theory OClosed_Transfer

(*  Title:       OClosed_Transfer.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Transfer open results onto closed models"

theory OClosed_Transfer
imports Closed OClosed_Lifting
begin

locale openproc =
  fixes np  :: "ip  ('s, ('m::msg) seq_action) automaton"
    and onp :: "ip  ((ip  'g) × 'l, 'm seq_action) automaton"
    and sr  :: "'s  ('g × 'l)"
  assumes  init: "{ (σ, ζ) |σ ζ s. s  init (np i)
                              (σ i, ζ) = sr s
                              (j. ji  σ j  (fst o sr) ` init (np j)) }  init (onp i)"
      and init_notempty: "j. init (np j)  {}"
      and trans: "s a s' σ σ'.  σ i = fst (sr s);
                                  σ' i = fst (sr s');
                                  (s, a, s')  trans (np i) 
                    ((σ, snd (sr s)), a, (σ', snd (sr s')))  trans (onp i)"
begin

lemma init_pnet_p_NodeS:
  assumes "NodeS i s R  init (pnet np p)"
    shows "p = i; R"
  using assms by (cases p) (auto simp add: node_comps)

lemma init_pnet_p_SubnetS:
  assumes "SubnetS s1 s2  init (pnet np p)"
  obtains p1 p2 where "p = (p1  p2)"
                  and "s1  init (pnet np p1)"
                  and "s2  init (pnet np p2)"
  using assms by (cases p) (auto simp add: node_comps)

lemma init_pnet_fst_sr_netgmap:
  assumes "s  init (pnet np p)"
      and "i  net_ips s"
      and "wf_net_tree p"
    shows "the (fst (netgmap sr s) i)  (fst  sr) ` init (np i)"
  using assms proof (induction s arbitrary: p)
    fix ii s Ri p
    assume "NodeS ii s Ri  init (pnet np p)"
       and "i  net_ips (NodeS ii s Ri)"
       and "wf_net_tree p"
    note this(1)
    moreover then have "p = ii; Ri"
      by (rule init_pnet_p_NodeS)
    ultimately have "s  init (np ii)"
      by (clarsimp simp: node_comps)
    with i  net_ips (NodeS ii s Ri)
      show "the (fst (netgmap sr (NodeS ii s Ri)) i)  (fst  sr) ` init (np i)"
        by clarsimp
  next
    fix s1 s2 p
    assume IH1: "p. s1  init (pnet np p)
                   i  net_ips s1
                   wf_net_tree p
                   the (fst (netgmap sr s1) i)  (fst  sr) ` init (np i)"
       and IH2: "p. s2  init (pnet np p)
                   i  net_ips s2
                   wf_net_tree p
                   the (fst (netgmap sr s2) i)  (fst  sr) ` init (np i)"
       and "SubnetS s1 s2  init (pnet np p)"
       and "i  net_ips (SubnetS s1 s2)"
       and "wf_net_tree p"
    from this(3) obtain p1 p2 where "p = (p1  p2)"
                                and "s1  init (pnet np p1)"
                                and "s2  init (pnet np p2)"
      by (rule init_pnet_p_SubnetS)
    from this(1) and ‹wf_net_tree p have "wf_net_tree p1"
                                      and "wf_net_tree p2"
                                      and "net_tree_ips p1  net_tree_ips p2 = {}"
      by auto
    from i  net_ips (SubnetS s1 s2) have "i  net_ips s1  i  net_ips s2"
      by simp
    thus "the (fst (netgmap sr (SubnetS s1 s2)) i)  (fst  sr) ` init (np i)"
    proof
      assume "i  net_ips s1"
      hence "i  net_ips s2"
      proof -
        from s1  init (pnet np p1) and i  net_ips s1 have "inet_tree_ips p1" ..
        with ‹net_tree_ips p1  net_tree_ips p2 = {} have "inet_tree_ips p2" by auto
        with s2  init (pnet np p2) show ?thesis ..
      qed
      moreover from s1  init (pnet np p1)  i  net_ips s1 and ‹wf_net_tree p1
        have "the (fst (netgmap sr s1) i)  (fst  sr) ` init (np i)"
          by (rule IH1)
      ultimately show ?thesis by simp
    next
      assume "i  net_ips s2"
      moreover with s2  init (pnet np p2) have "the (fst (netgmap sr s2) i)  (fst  sr) ` init (np i)"
        using ‹wf_net_tree p2 by (rule IH2)
      moreover from s2  init (pnet np p2) and i  net_ips s2 have "inet_tree_ips p2" ..
      ultimately show ?thesis by simp
    qed
  qed

lemma init_lifted:
  assumes "wf_net_tree p"                                                          
  shows "{ (σ, snd (netgmap sr s)) |σ s. s  init (pnet np p)
                                (i. if inet_tree_ips p then σ i = the (fst (netgmap sr s) i)
                                      else σ i  (fst o sr) ` init (np i)) }  init (opnet onp p)"
  using assms proof (induction p)
    fix i R
    assume "wf_net_tree i; R"
    show "{(σ, snd (netgmap sr s)) |σ s. s  init (pnet np i; R)
             (j. if j  net_tree_ips i; R then σ j = the (fst (netgmap sr s) j)
                   else σ j  (fst  sr) ` init (np j))}  init (opnet onp i; R)"
      by (clarsimp simp add: node_comps onode_comps)
         (rule subsetD [OF init], auto)
  next
    fix p1 p2
    assume IH1: "wf_net_tree p1
                 {(σ, snd (netgmap sr s)) |σ s. s  init (pnet np p1)
                       (i. if i  net_tree_ips p1 then σ i = the (fst (netgmap sr s) i)
                             else σ i  (fst  sr) ` init (np i))}  init (opnet onp p1)"
                (is "_  ?S1  _")
       and IH2: "wf_net_tree p2
                  {(σ, snd (netgmap sr s)) |σ s. s  init (pnet np p2)
                        (i. if i  net_tree_ips p2 then σ i = the (fst (netgmap sr s) i)
                              else σ i  (fst  sr) ` init (np i))}  init (opnet onp p2)"
                (is "_  ?S2  _")
        and "wf_net_tree (p1  p2)"
    from this(3) have "wf_net_tree p1"
                  and "wf_net_tree p2"
                  and "net_tree_ips p1  net_tree_ips p2 = {}" by auto
    show "{(σ, snd (netgmap sr s)) |σ s. s  init (pnet np (p1  p2))
             (i. if i  net_tree_ips (p1  p2) then σ i = the (fst (netgmap sr s) i)
                   else σ i  (fst  sr) ` init (np i))}  init (opnet onp (p1  p2))"
    proof (rule, clarsimp simp only: split_paired_all pnet.simps automaton.simps)
      fix σ s1 s2
      assume σ_desc: "i. if i  net_tree_ips (p1  p2)
                          then σ i = the (fst (netgmap sr (SubnetS s1 s2)) i)
                          else σ i  (fst  sr) ` init (np i)"
         and "s1  init (pnet np p1)"
         and "s2  init (pnet np p2)"
      from this(2-3) have "net_ips s1 = net_tree_ips p1"
                      and "net_ips s2 = net_tree_ips p2" by auto
      have "(σ, snd (netgmap sr s1))  ?S1"
      proof -
        { fix i
          assume "i  net_tree_ips p1"
          with ‹net_tree_ips p1  net_tree_ips p2 = {} have "i  net_tree_ips p2" by auto
          with s2  init (pnet np p2) have "i  net_ips s2" ..
          hence "the ((fst (netgmap sr s1) ++ fst (netgmap sr s2)) i) = the (fst (netgmap sr s1) i)"
            by simp
        }
        moreover
        { fix i
          assume "i  net_tree_ips p1"
          have "σ i  (fst  sr) ` init (np i)"
          proof (cases "i  net_tree_ips p2")
            assume "i  net_tree_ips p2"
            with i  net_tree_ips p1 and σ_desc show ?thesis
              by (auto dest: spec [of _ i])
          next
            assume "i  net_tree_ips p2"
            with s2  init (pnet np p2) have "i  net_ips s2" ..
            with s2  init (pnet np p2) have "the (fst (netgmap sr s2) i)  (fst  sr) ` init (np i)"
              using ‹wf_net_tree p2 by (rule init_pnet_fst_sr_netgmap)
            with inet_tree_ips p2 and inet_ips s2 show ?thesis
              using σ_desc by simp
          qed
        }
        ultimately show ?thesis
          using s1  init (pnet np p1) and σ_desc by auto
      qed
      hence "(σ, snd (netgmap sr s1))  init (opnet onp p1)"
        by (rule subsetD [OF IH1 [OF ‹wf_net_tree p1]])

      have "(σ, snd (netgmap sr s2))  ?S2"
      proof -
        { fix i
          assume "i  net_tree_ips p2"
          with s2  init (pnet np p2) have "i  net_ips s2" ..
          hence "the ((fst (netgmap sr s1) ++ fst (netgmap sr s2)) i) = the (fst (netgmap sr s2) i)"
            by simp
        }
        moreover
        { fix i
          assume "i  net_tree_ips p2"
          have "σ i  (fst  sr) ` init (np i)"
          proof (cases "i  net_tree_ips p1")
            assume "i  net_tree_ips p1"
            with i  net_tree_ips p2 and σ_desc show ?thesis
              by (auto dest: spec [of _ i])
          next
            assume "i  net_tree_ips p1"
            with s1  init (pnet np p1) have "i  net_ips s1" ..
            with s1  init (pnet np p1) have "the (fst (netgmap sr s1) i)  (fst  sr) ` init (np i)"
              using ‹wf_net_tree p1 by (rule init_pnet_fst_sr_netgmap)
            moreover from s2  init (pnet np p2) and i  net_tree_ips p2 have "inet_ips s2" ..
            ultimately show ?thesis
              using inet_tree_ips p1 inet_ips s1 and inet_tree_ips p2 σ_desc by simp
          qed
        }
        ultimately show ?thesis
          using s2  init (pnet np p2) and σ_desc by auto
      qed
      hence "(σ, snd (netgmap sr s2))  init (opnet onp p2)"
        by (rule subsetD [OF IH2 [OF ‹wf_net_tree p2]])

      with (σ, snd (netgmap sr s1))  init (opnet onp p1)
        show "(σ, snd (netgmap sr (SubnetS s1 s2)))  init (opnet onp (p1  p2))"
        using ‹net_tree_ips p1  net_tree_ips p2 = {}
              ‹net_ips s1 = net_tree_ips p1
              ‹net_ips s2 = net_tree_ips p2 by simp
    qed
  qed

lemma init_pnet_opnet [elim]:
  assumes "wf_net_tree p"
      and "s  init (pnet np p)"
    shows "netgmap sr s  netmask (net_tree_ips p) ` init (opnet onp p)"
  proof -
    from ‹wf_net_tree p
      have "{ (σ, snd (netgmap sr s)) |σ s. s  init (pnet np p)
                               (i. if inet_tree_ips p then σ i = the (fst (netgmap sr s) i)
                                     else σ i  (fst o sr) ` init (np i)) }  init (opnet onp p)"
        (is "?S  _")
      by (rule init_lifted)
    hence "netmask (net_tree_ips p) ` ?S  netmask (net_tree_ips p) ` init (opnet onp p)"
      by (rule image_mono)
    moreover have "netgmap sr s  netmask (net_tree_ips p) ` ?S"
    proof -
      { fix i
        from init_notempty have "s. s  (fst  sr) ` init (np i)" by auto
        hence "(SOME x. x  (fst  sr) ` init (np i))  (fst  sr) ` init (np i)" ..
      }
      with s  init (pnet np p) and init_notempty
        have "(λi. if i  net_tree_ips p
                   then the (fst (netgmap sr s) i)
                   else SOME x. x  (fst  sr) ` init (np i), snd (netgmap sr s))  ?S"
          (is "?s  ?S") by auto
      moreover have "netgmap sr s = netmask (net_tree_ips p) ?s"
      proof (intro prod_eqI ext)
        fix i
        show "fst (netgmap sr s) i = fst (netmask (net_tree_ips p) ?s) i"
        proof (cases "i  net_tree_ips p")
          assume "i  net_tree_ips p"
          with sinit (pnet np p) have "inet_ips s" ..
          hence "Some (the (fst (netgmap sr s) i)) = fst (netgmap sr s) i"
            by (rule some_the_fst_netgmap)
          with inet_tree_ips p show ?thesis
            by simp
        next
          assume "i  net_tree_ips p"
          moreover with sinit (pnet np p) have "inet_ips s" ..
          ultimately show ?thesis
            by simp
        qed
      qed simp
      ultimately show ?thesis
        by (rule rev_image_eqI)
    qed
    ultimately show ?thesis
      by (rule rev_subsetD [rotated])
  qed

lemma transfer_connect:
  assumes "(s, connect(i, i'), s')  trans (pnet np n)"
      and "s  reachable (pnet np n) TT"
      and "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
  obtains σ' ζ' where "((σ, ζ), connect(i, i'), (σ', ζ'))  trans (opnet onp n)"
                  and "j. jnet_ips ζ  σ' j = σ j"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    from assms have "((σ, snd (netgmap sr s)), connect(i, i'), (σ, snd (netgmap sr s')))  trans (opnet onp n)
                      netgmap sr s' = netmask (net_tree_ips n) (σ, snd (netgmap sr s'))"
      proof (induction n arbitrary: s s' ζ)
        fix ii Ri ns ns' ζ
        assume "(ns, connect(i, i'), ns')  trans (pnet np ii; Ri)"
           and "netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)"
        from this(1) have "(ns, connect(i, i'), ns')  node_sos (trans (np ii))"
          by (simp add: node_comps)
        moreover then obtain ni s s' R R' where "ns  = NodeS ni s R"
                                            and "ns' = NodeS ni s' R'" ..
        ultimately have "(NodeS ni s R, connect(i, i'), NodeS ni s' R')  node_sos (trans (np ii))"
          by simp
        moreover then have "s' = s" by auto
        ultimately have "((σ, NodeS ni (snd (sr s)) R), connect(i, i'), (σ, NodeS ni (snd (sr s)) R'))
                                                                       onode_sos (trans (onp ii))"
          by - (rule node_connectTE', auto intro!: onode_sos.intros [simplified])
        with ns = NodeS ni s R ns' = NodeS ni s' R' s' = s
             and ‹netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)
          show "((σ, snd (netgmap sr ns)), connect(i, i'), (σ, snd (netgmap sr ns')))  trans (opnet onp ii; Ri)
                 netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ, snd (netgmap sr ns'))"
            by (simp add: onode_comps)
      next
        fix n1 n2 s s' ζ
        assume IH1: "s s' ζ. (s, connect(i, i'), s')  trans (pnet np n1)
                       s  reachable (pnet np n1) TT
                       netgmap sr s = netmask (net_tree_ips n1) (σ, ζ)
                       wf_net_tree n1
                       ((σ, snd (netgmap sr s)), connect(i, i'), (σ, snd (netgmap sr s')))  trans (opnet onp n1)
                           netgmap sr s' = netmask (net_tree_ips n1) (σ, snd (netgmap sr s'))"
           and IH2: "s s' ζ. (s, connect(i, i'), s')  trans (pnet np n2)
                       s  reachable (pnet np n2) TT
                       netgmap sr s = netmask (net_tree_ips n2) (σ, ζ)
                       wf_net_tree n2
                       ((σ, snd (netgmap sr s)), connect(i, i'), (σ, snd (netgmap sr s')))  trans (opnet onp n2)
                           netgmap sr s' = netmask (net_tree_ips n2) (σ, snd (netgmap sr s'))"
           and tr: "(s, connect(i, i'), s')  trans (pnet np (n1  n2))"
           and sr: "s  reachable (pnet np (n1  n2)) TT"
           and nm: "netgmap sr s = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
           and "wf_net_tree (n1  n2)"
        from this(3) have "(s, connect(i, i'), s')  pnet_sos (trans (pnet np n1))
                                                               (trans (pnet np n2))"
          by simp
        then obtain s1 s1' s2 s2' where "s = SubnetS s1 s2"
                                    and "s' = SubnetS s1' s2'"
                                    and "(s1, connect(i, i'), s1')  trans (pnet np n1)"
                                    and "(s2, connect(i, i'), s2')  trans (pnet np n2)"
          by (rule partial_connectTE) auto
        from this(1) and nm have "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
          by simp

        from ‹wf_net_tree (n1  n2) have "wf_net_tree n1" and "wf_net_tree n2"
                                      and "net_tree_ips n1  net_tree_ips n2 = {}" by auto

        from sr s = SubnetS s1 s2 have "s1  reachable (pnet np n1) TT" by (metis subnet_reachable(1))
        hence "net_ips s1 = net_tree_ips n1" by (rule pnet_net_ips_net_tree_ips)

        from sr s = SubnetS s1 s2 have "s2  reachable (pnet np n2) TT" by (metis subnet_reachable(2))
        hence "net_ips s2 = net_tree_ips n2" by (rule pnet_net_ips_net_tree_ips)

        from nm s = SubnetS s1 s2
          have "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)" by simp
        hence "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
          using ‹net_tree_ips n1  net_tree_ips n2 = {} ‹net_ips s1 = net_tree_ips n1
                and ‹net_ips s2 = net_tree_ips n2 by (rule netgmap_subnet_split1)
        with (s1, connect(i, i'), s1')  trans (pnet np n1)
         and s1  reachable (pnet np n1) TT›
         have "((σ, snd (netgmap sr s1)), connect(i, i'), (σ, snd (netgmap sr s1')))  trans (opnet onp n1)"
          and "netgmap sr s1' = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1'))"
           using ‹wf_net_tree n1 unfolding atomize_conj by (rule IH1)

        from ‹netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)
             ‹net_ips s1 = net_tree_ips n1 and ‹net_ips s2 = net_tree_ips n2
          have "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
            by (rule netgmap_subnet_split2)
        with (s2, connect(i, i'), s2')  trans (pnet np n2)
         and s2  reachable (pnet np n2) TT›
         have "((σ, snd (netgmap sr s2)), connect(i, i'), (σ, snd (netgmap sr s2')))  trans (opnet onp n2)"
          and "netgmap sr s2' = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2'))"
           using ‹wf_net_tree n2 unfolding atomize_conj by (rule IH2)

        have "((σ, snd (netgmap sr s)), connect(i, i'), (σ, snd (netgmap sr s')))
                                          trans (opnet onp (n1  n2))"
        proof -
          from ((σ, snd (netgmap sr s1)), connect(i, i'), (σ, snd (netgmap sr s1')))  trans (opnet onp n1)
           and ((σ, snd (netgmap sr s2)), connect(i, i'), (σ, snd (netgmap sr s2')))  trans (opnet onp n2)
            have "((σ, SubnetS (snd (netgmap sr s1)) (snd (netgmap sr s2))), connect(i, i'),
                   (σ, SubnetS (snd (netgmap sr s1')) (snd (netgmap sr s2'))))
                                            opnet_sos (trans (opnet onp n1)) (trans (opnet onp n2))"
              by (rule opnet_connect)
          with s = SubnetS s1 s2 s' = SubnetS s1' s2' show ?thesis by simp
        qed

        moreover from ‹netgmap sr s1' = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1'))
                      ‹netgmap sr s2' = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2'))
                      s' = SubnetS s1' s2'
          have "netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ, snd (netgmap sr s'))" ..

        ultimately show "((σ, snd (netgmap sr s)), connect(i, i'), (σ, snd (netgmap sr s')))
                                                                 trans (opnet onp (n1  n2))
                          netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ, snd (netgmap sr s'))" ..
      qed
    moreover from ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ) have "ζ = snd (netgmap sr s)" by simp
    ultimately show " σ' ζ'. ((σ, ζ), connect(i, i'), (σ', ζ'))  trans (opnet onp n)
                               (j. j  net_ips ζ  σ' j = σ j)
                               netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')" by auto
  qed

lemma transfer_disconnect:
  assumes "(s, disconnect(i, i'), s')  trans (pnet np n)"
      and "s  reachable (pnet np n) TT"
      and "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
  obtains σ' ζ' where "((σ, ζ), disconnect(i, i'), (σ', ζ'))  trans (opnet onp n)"
                  and "j. jnet_ips ζ  σ' j = σ j"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    from assms have "((σ, snd (netgmap sr s)), disconnect(i, i'), (σ, snd (netgmap sr s')))  trans (opnet onp n)
                      netgmap sr s' = netmask (net_tree_ips n) (σ, snd (netgmap sr s'))"
      proof (induction n arbitrary: s s' ζ)
        fix ii Ri ns ns' ζ
        assume "(ns, disconnect(i, i'), ns')  trans (pnet np ii; Ri)"
           and "netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)"
        from this(1) have "(ns, disconnect(i, i'), ns')  node_sos (trans (np ii))"
          by (simp add: node_comps)
        moreover then obtain ni s s' R R' where "ns  = NodeS ni s R"
                                            and "ns' = NodeS ni s' R'" ..
        ultimately have "(NodeS ni s R, disconnect(i, i'), NodeS ni s' R')  node_sos (trans (np ii))"
          by simp
        moreover then have "s' = s" by auto
        ultimately have "((σ, NodeS ni (snd (sr s)) R), disconnect(i, i'), (σ, NodeS ni (snd (sr s)) R'))
                                                                       onode_sos (trans (onp ii))"
          by - (rule node_disconnectTE', auto intro!: onode_sos.intros [simplified])
        with ns = NodeS ni s R ns' = NodeS ni s' R' s' = s
             and ‹netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)
          show "((σ, snd (netgmap sr ns)), disconnect(i, i'), (σ, snd (netgmap sr ns')))  trans (opnet onp ii; Ri)
                 netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ, snd (netgmap sr ns'))"
            by (simp add: onode_comps)
      next
        fix n1 n2 s s' ζ
        assume IH1: "s s' ζ. (s, disconnect(i, i'), s')  trans (pnet np n1)
                       s  reachable (pnet np n1) TT
                       netgmap sr s = netmask (net_tree_ips n1) (σ, ζ)
                       wf_net_tree n1
                       ((σ, snd (netgmap sr s)), disconnect(i, i'), (σ, snd (netgmap sr s')))  trans (opnet onp n1)
                           netgmap sr s' = netmask (net_tree_ips n1) (σ, snd (netgmap sr s'))"
           and IH2: "s s' ζ. (s, disconnect(i, i'), s')  trans (pnet np n2)
                       s  reachable (pnet np n2) TT
                       netgmap sr s = netmask (net_tree_ips n2) (σ, ζ)
                       wf_net_tree n2
                       ((σ, snd (netgmap sr s)), disconnect(i, i'), (σ, snd (netgmap sr s')))  trans (opnet onp n2)
                           netgmap sr s' = netmask (net_tree_ips n2) (σ, snd (netgmap sr s'))"
           and tr: "(s, disconnect(i, i'), s')  trans (pnet np (n1  n2))"
           and sr: "s  reachable (pnet np (n1  n2)) TT"
           and nm: "netgmap sr s = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
           and "wf_net_tree (n1  n2)"
        from this(3) have "(s, disconnect(i, i'), s')  pnet_sos (trans (pnet np n1))
                                                               (trans (pnet np n2))"
          by simp
        then obtain s1 s1' s2 s2' where "s = SubnetS s1 s2"
                                    and "s' = SubnetS s1' s2'"
                                    and "(s1, disconnect(i, i'), s1')  trans (pnet np n1)"
                                    and "(s2, disconnect(i, i'), s2')  trans (pnet np n2)"
          by (rule partial_disconnectTE) auto
        from this(1) and nm have "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
          by simp

        from ‹wf_net_tree (n1  n2) have "wf_net_tree n1" and "wf_net_tree n2"
                                      and "net_tree_ips n1  net_tree_ips n2 = {}" by auto

        from sr s = SubnetS s1 s2 have "s1  reachable (pnet np n1) TT" by (metis subnet_reachable(1))
        hence "net_ips s1 = net_tree_ips n1" by (rule pnet_net_ips_net_tree_ips)

        from sr s = SubnetS s1 s2 have "s2  reachable (pnet np n2) TT" by (metis subnet_reachable(2))
        hence "net_ips s2 = net_tree_ips n2" by (rule pnet_net_ips_net_tree_ips)

        from nm s = SubnetS s1 s2
          have "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)" by simp
        hence "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
          using ‹net_tree_ips n1  net_tree_ips n2 = {} ‹net_ips s1 = net_tree_ips n1
                and ‹net_ips s2 = net_tree_ips n2 by (rule netgmap_subnet_split1)
        with (s1, disconnect(i, i'), s1')  trans (pnet np n1)
         and s1  reachable (pnet np n1) TT›
         have "((σ, snd (netgmap sr s1)), disconnect(i, i'), (σ, snd (netgmap sr s1')))  trans (opnet onp n1)"
          and "netgmap sr s1' = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1'))"
           using ‹wf_net_tree n1 unfolding atomize_conj by (rule IH1)

        from ‹netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)
             ‹net_ips s1 = net_tree_ips n1 and ‹net_ips s2 = net_tree_ips n2
          have "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
            by (rule netgmap_subnet_split2)
        with (s2, disconnect(i, i'), s2')  trans (pnet np n2)
         and s2  reachable (pnet np n2) TT›
         have "((σ, snd (netgmap sr s2)), disconnect(i, i'), (σ, snd (netgmap sr s2')))  trans (opnet onp n2)"
          and "netgmap sr s2' = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2'))"
           using ‹wf_net_tree n2 unfolding atomize_conj by (rule IH2)

        have "((σ, snd (netgmap sr s)), disconnect(i, i'), (σ, snd (netgmap sr s')))
                                          trans (opnet onp (n1  n2))"
        proof -
          from ((σ, snd (netgmap sr s1)), disconnect(i, i'), (σ, snd (netgmap sr s1')))  trans (opnet onp n1)
           and ((σ, snd (netgmap sr s2)), disconnect(i, i'), (σ, snd (netgmap sr s2')))  trans (opnet onp n2)
            have "((σ, SubnetS (snd (netgmap sr s1)) (snd (netgmap sr s2))), disconnect(i, i'),
                   (σ, SubnetS (snd (netgmap sr s1')) (snd (netgmap sr s2'))))
                                            opnet_sos (trans (opnet onp n1)) (trans (opnet onp n2))"
              by (rule opnet_disconnect)
          with s = SubnetS s1 s2 s' = SubnetS s1' s2' show ?thesis by simp
        qed

        moreover from ‹netgmap sr s1' = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1'))
                      ‹netgmap sr s2' = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2'))
                      s' = SubnetS s1' s2'
          have "netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ, snd (netgmap sr s'))" ..

        ultimately show "((σ, snd (netgmap sr s)), disconnect(i, i'), (σ, snd (netgmap sr s')))
                                                                 trans (opnet onp (n1  n2))
                          netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ, snd (netgmap sr s'))" ..
      qed
    moreover from ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ) have "ζ = snd (netgmap sr s)" by simp
    ultimately show "σ' ζ'. ((σ, ζ), disconnect(i, i'), (σ', ζ'))  trans (opnet onp n)
                               (j. j  net_ips ζ  σ' j = σ j)
                               netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')" by auto
  qed

lemma transfer_tau:
  assumes "(s, τ, s')  trans (pnet np n)"
      and "s  reachable (pnet np n) TT"
      and "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
  obtains σ' ζ' where "((σ, ζ), τ, (σ', ζ'))  trans (opnet onp n)"
                  and "j. jnet_ips ζ  σ' j = σ j"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    from assms(4,2,1) obtain i where "inet_ips s"
                                 and "j. ji  netmap s' j = netmap s j"
                                 and "net_ip_action np τ i n s s'"
      by (metis pnet_tau_single_node)
    from this(2) have "j. ji  fst (netgmap sr s') j = fst (netgmap sr s) j"
      by (clarsimp intro!: netmap_is_fst_netgmap')
    from (s, τ, s')  trans (pnet np n) have "net_ips s' = net_ips s"
      by (rule pnet_maintains_dom [THEN sym])
    define σ' where "σ' j = (if j = i then the (fst (netgmap sr s') i) else σ j)" for j
    from j. ji  fst (netgmap sr s') j = fst (netgmap sr s) j
         and ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "j. ji  σ' j = σ j"
        unfolding σ'_def by clarsimp

    from assms(2) have "net_ips s = net_tree_ips n"
      by (rule pnet_net_ips_net_tree_ips)

    from ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "ζ = snd (netgmap sr s)" by simp

    from j. ji  fst (netgmap sr s') j = fst (netgmap sr s) j i  net_ips s
         ‹net_ips s = net_tree_ips n ‹net_ips s' = net_ips s
         ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "fst (netgmap sr s') = fst (netmask (net_tree_ips n) (σ', snd (netgmap sr s')))"
        unfolding σ'_def [abs_def] by - (rule ext, clarsimp)

    hence "netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))"
      by (rule prod_eqI, simp)

    with assms(1, 3)
      have "((σ, snd (netgmap sr s)), τ, (σ', snd (netgmap sr s')))  trans (opnet onp n)"
        using assms(2,4) inet_ips s and ‹net_ip_action np τ i n s s'
    proof (induction n arbitrary: s s' ζ)
      fix ii Ri ns ns' ζ
      assume "(ns, τ, ns')  trans (pnet np ii; Ri)"
         and nsr: "ns  reachable (pnet np ii; Ri) TT"
         and "netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)"
         and "netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))"
         and "inet_ips ns"
      from this(1) have "(ns, τ, ns')  node_sos (trans (np ii))"
        by (simp add: node_comps)
      moreover with nsr obtain s s' R R' where "ns  = NodeS ii s R"
                                           and "ns' = NodeS ii s' R'"
         by (metis net_node_reachable_is_node node_tauTE')
      moreover from i  net_ips ns and ns  = NodeS ii s R have "ii = i" by simp
      ultimately have ntr: "(NodeS i s R, τ, NodeS i s' R')  node_sos (trans (np i))"
        by simp
      hence "R' = R" by (metis net_state.inject(1) node_tauTE')

      from ntr obtain a where "(s, a, s')  trans (np i)"
                          and "(d. a = ¬unicast d  dR)  (a = τ)"
        by (rule node_tauTE') auto

      from ‹netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ) ns  = NodeS ii s R and ii = i
        have "σ i = fst (sr s)" by simp (metis map_upd_Some_unfold)

      moreover from ‹netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))
                    ns' = NodeS ii s' R' and ii = i
        have "σ' i = fst (sr s')"
          unfolding σ'_def [abs_def] by clarsimp (hypsubst_thin,
                                        metis (full_types, lifting) fun_upd_same option.sel)
      ultimately have "((σ, snd (sr s)), a, (σ', snd (sr s')))  trans (onp i)"
        using (s, a, s')  trans (np i) by (rule trans)

      from (d. a = ¬unicast d  dR)  (a = τ) j. ji  σ' j = σ j R'=R
           and ((σ, snd (sr s)), a, (σ', snd (sr s')))  trans (onp i)
        have "((σ, NodeS i (snd (sr s)) R), τ, (σ', NodeS i (snd (sr s')) R'))  onode_sos (trans (onp i))"
          by (metis onode_sos.onode_notucast onode_sos.onode_tau)

      with ns  = NodeS ii s R ns' = NodeS ii s' R' ii = i
        show "((σ, snd (netgmap sr ns)), τ, (σ', snd (netgmap sr ns')))  trans (opnet onp ii; Ri)"
          by (simp add: onode_comps)
    next
      fix n1 n2 s s' ζ
      assume IH1: "s s' ζ. (s, τ, s')  trans (pnet np n1)
                     netgmap sr s = netmask (net_tree_ips n1) (σ, ζ)
                     netgmap sr s' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s'))
                     s  reachable (pnet np n1) TT
                     wf_net_tree n1
                     inet_ips s
                     net_ip_action np τ i n1 s s'
                     ((σ, snd (netgmap sr s)), τ, (σ', snd (netgmap sr s')))  trans (opnet onp n1)"
         and IH2: "s s' ζ. (s, τ, s')  trans (pnet np n2)
                     netgmap sr s = netmask (net_tree_ips n2) (σ, ζ)
                     netgmap sr s' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s'))
                     s  reachable (pnet np n2) TT
                     wf_net_tree n2
                     inet_ips s
                     net_ip_action np τ i n2 s s'
                     ((σ, snd (netgmap sr s)), τ, (σ', snd (netgmap sr s')))  trans (opnet onp n2)"
         and tr: "(s, τ, s')  trans (pnet np (n1  n2))"
         and sr: "s  reachable (pnet np (n1  n2)) TT"
         and nm: "netgmap sr s = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
         and nm': "netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ', snd (netgmap sr s'))"
         and "wf_net_tree (n1  n2)"
         and "inet_ips s"
         and "net_ip_action np τ i (n1  n2) s s'"
      from tr have "(s, τ, s')  pnet_sos (trans (pnet np n1)) (trans (pnet np n2))" by simp
      then obtain s1 s1' s2 s2' where "s = SubnetS s1 s2"
                                  and "s' = SubnetS s1' s2'"
        by (rule partial_tauTE) auto
      from this(1) and nm have "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
        by simp
      from s' = SubnetS s1' s2' and nm'
        have "netgmap sr (SubnetS s1' s2') = netmask (net_tree_ips (n1  n2)) (σ', snd (netgmap sr s'))"
          by simp

      from ‹wf_net_tree (n1  n2) have "wf_net_tree n1"
                                    and "wf_net_tree n2"
                                    and "net_tree_ips n1  net_tree_ips n2 = {}" by auto

      from sr [simplified s = SubnetS s1 s2] have "s1  reachable (pnet np n1) TT"
        by (rule subnet_reachable(1))
      hence "net_ips s1 = net_tree_ips n1" by (rule pnet_net_ips_net_tree_ips)

      from sr [simplified s = SubnetS s1 s2] have "s2  reachable (pnet np n2) TT"
        by (rule subnet_reachable(2))
      hence "net_ips s2 = net_tree_ips n2" by (rule pnet_net_ips_net_tree_ips)

      from nm [simplified s = SubnetS s1 s2]
           ‹net_tree_ips n1  net_tree_ips n2 = {}
           ‹net_ips s1 = net_tree_ips n1
           ‹net_ips s2 = net_tree_ips n2 
        have "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
          by (rule netgmap_subnet_split1)

      from nm [simplified s = SubnetS s1 s2]
           ‹net_ips s1 = net_tree_ips n1
           ‹net_ips s2 = net_tree_ips n2 
        have "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
          by (rule netgmap_subnet_split2)

      from inet_ips s and s = SubnetS s1 s2 have "inet_ips s1  inet_ips s2" by auto
        thus "((σ, snd (netgmap sr s)), τ, (σ', snd (netgmap sr s')))  trans (opnet onp (n1  n2))"
      proof
        assume "inet_ips s1"
        with s = SubnetS s1 s2 s' = SubnetS s1' s2' ‹net_ip_action np τ i (n1  n2) s s'
          have "(s1, τ, s1')  trans (pnet np n1)"
           and "net_ip_action np τ i n1 s1 s1'"
           and "s2' = s2" by simp_all

        from ‹net_ips s1 = net_tree_ips n1 and (s1, τ, s1')  trans (pnet np n1)
          have "net_ips s1' = net_tree_ips n1" by (metis pnet_maintains_dom)

        from nm' [simplified s' = SubnetS s1' s2' s2' = s2]
                        ‹net_tree_ips n1  net_tree_ips n2 = {}
                        ‹net_ips s1' = net_tree_ips n1
                        ‹net_ips s2 = net_tree_ips n2
          have "netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))"
            by (rule netgmap_subnet_split1)

        from (s1, τ, s1')  trans (pnet np n1)
             ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))
             ‹netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))
             s1  reachable (pnet np n1) TT›
             ‹wf_net_tree n1
             inet_ips s1
             ‹net_ip_action np τ i n1 s1 s1'
          have "((σ, snd (netgmap sr s1)), τ, (σ', snd (netgmap sr s1')))  trans (opnet onp n1)"
             by (rule IH1)

        with s = SubnetS s1 s2 s' = SubnetS s1' s2' s2' = s2 show ?thesis
          by (simp del: step_node_tau) (erule opnet_tau1)
      next
        assume "inet_ips s2"
        with s = SubnetS s1 s2 s' = SubnetS s1' s2' ‹net_ip_action np τ i (n1  n2) s s'
          have "(s2, τ, s2')  trans (pnet np n2)"
           and "net_ip_action np τ i n2 s2 s2'"
           and "s1' = s1" by simp_all

        from ‹net_ips s2 = net_tree_ips n2 and (s2, τ, s2')  trans (pnet np n2)
          have "net_ips s2' = net_tree_ips n2" by (metis pnet_maintains_dom)

        from nm' [simplified s' = SubnetS s1' s2' s1' = s1]
                        ‹net_ips s1 = net_tree_ips n1
                        ‹net_ips s2' = net_tree_ips n2
          have "netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))"
            by (rule netgmap_subnet_split2)

        from (s2, τ, s2')  trans (pnet np n2)
             ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))
             ‹netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))
             s2  reachable (pnet np n2) TT›
             ‹wf_net_tree n2
             inet_ips s2
             ‹net_ip_action np τ i n2 s2 s2'
          have "((σ, snd (netgmap sr s2)), τ, (σ', snd (netgmap sr s2')))  trans (opnet onp n2)"
             by (rule IH2)

        with s = SubnetS s1 s2 s' = SubnetS s1' s2' s1' = s1 show ?thesis
          by (simp del: step_node_tau) (erule opnet_tau2)
      qed
    qed
    with ζ = snd (netgmap sr s) have "((σ, ζ), τ, (σ', snd (netgmap sr s')))  trans (opnet onp n)"
      by simp
    moreover from j. ji  σ' j = σ j i  net_ips s ζ = snd (netgmap sr s)
      have "j. jnet_ips ζ  σ' j = σ j" by (metis net_ips_netgmap)
    ultimately have "((σ, ζ), τ, (σ', snd (netgmap sr s')))  trans (opnet onp n)
                      (j. jnet_ips ζ  σ' j = σ j)
                      netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))"
      using ‹netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s')) by simp
    thus "σ' ζ'. ((σ, ζ), τ, (σ', ζ'))  trans (opnet onp n)
                   (j. jnet_ips ζ  σ' j = σ j)
                   netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')" by auto
  qed

lemma transfer_deliver:
  assumes "(s, i:deliver(d), s')  trans (pnet np n)"
      and "s  reachable (pnet np n) TT"
      and "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
  obtains σ' ζ' where "((σ, ζ), i:deliver(d), (σ', ζ'))  trans (opnet onp n)"
                  and "j. jnet_ips ζ  σ' j = σ j"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    from assms(4,2,1) obtain "inet_ips s"
                         and "j. ji  netmap s' j = netmap s j"
                         and "net_ip_action np (i:deliver(d)) i n s s'"
      by (metis delivered_to_net_ips pnet_deliver_single_node)
    from this(2) have "j. ji  fst (netgmap sr s') j = fst (netgmap sr s) j"
      by (clarsimp intro!: netmap_is_fst_netgmap')
    from (s, i:deliver(d), s')  trans (pnet np n) have "net_ips s' = net_ips s"
      by (rule pnet_maintains_dom [THEN sym])
    define σ' where "σ' j = (if j = i then the (fst (netgmap sr s') i) else σ j)" for j
    from j. ji  fst (netgmap sr s') j = fst (netgmap sr s) j
         and ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "j. ji  σ' j = σ j"
        unfolding σ'_def by clarsimp

    from assms(2) have "net_ips s = net_tree_ips n"
      by (rule pnet_net_ips_net_tree_ips)

    from ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "ζ = snd (netgmap sr s)" by simp

    from j. ji  fst (netgmap sr s') j = fst (netgmap sr s) j i  net_ips s
         ‹net_ips s = net_tree_ips n ‹net_ips s' = net_ips s
         ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "fst (netgmap sr s') = fst (netmask (net_tree_ips n) (σ', snd (netgmap sr s')))"
        unfolding σ'_def [abs_def] by - (rule ext, clarsimp)

    hence "netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))"
      by (rule prod_eqI, simp)

    with assms(1, 3)
      have "((σ, snd (netgmap sr s)), i:deliver(d), (σ', snd (netgmap sr s')))  trans (opnet onp n)"
        using assms(2,4) inet_ips s and ‹net_ip_action np (i:deliver(d)) i n s s'
    proof (induction n arbitrary: s s' ζ)
      fix ii Ri ns ns' ζ
      assume "(ns, i:deliver(d), ns')  trans (pnet np ii; Ri)"
         and nsr: "ns  reachable (pnet np ii; Ri) TT"
         and "netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)"
         and "netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))"
         and "inet_ips ns"
      from this(1) have "(ns, i:deliver(d), ns')  node_sos (trans (np ii))"
        by (simp add: node_comps)
      moreover with nsr obtain s s' R R' where "ns  = NodeS ii s R"
                                           and "ns' = NodeS ii s' R'"
         by (metis net_node_reachable_is_node node_sos_dest)
      moreover from i  net_ips ns and ns  = NodeS ii s R have "ii = i" by simp
      ultimately have ntr: "(NodeS i s R, i:deliver(d), NodeS i s' R')  node_sos (trans (np i))"
        by simp
      hence "R' = R" by (metis net_state.inject(1) node_deliverTE')

      from ntr have "(s, deliver d, s')  trans (np i)"
        by (rule node_deliverTE') simp

      from ‹netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ) ns  = NodeS ii s R and ii = i
        have "σ i = fst (sr s)" by simp (metis map_upd_Some_unfold)

      moreover from ‹netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))
                    ns' = NodeS ii s' R' and ii = i
        have "σ' i = fst (sr s')"
          unfolding σ'_def [abs_def] by clarsimp (hypsubst_thin,
                                        metis (lifting, full_types) fun_upd_same option.sel)
      ultimately have "((σ, snd (sr s)), deliver d, (σ', snd (sr s')))  trans (onp i)"
        using (s, deliver d, s')  trans (np i) by (rule trans)

      with j. ji  σ' j = σ j R'=R
        have "((σ, NodeS i (snd (sr s)) R), i:deliver(d), (σ', NodeS i (snd (sr s')) R'))
                                                                       onode_sos (trans (onp i))"
          by (metis onode_sos.onode_deliver)

      with ns  = NodeS ii s R ns' = NodeS ii s' R' ii = i
        show "((σ, snd (netgmap sr ns)), i:deliver(d), (σ', snd (netgmap sr ns')))  trans (opnet onp ii; Ri)"
          by (simp add: onode_comps)
    next
      fix n1 n2 s s' ζ
      assume IH1: "s s' ζ. (s, i:deliver(d), s')  trans (pnet np n1)
                     netgmap sr s = netmask (net_tree_ips n1) (σ, ζ)
                     netgmap sr s' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s'))
                     s  reachable (pnet np n1) TT
                     wf_net_tree n1
                     inet_ips s
                     net_ip_action np (i:deliver(d)) i n1 s s'
                     ((σ, snd (netgmap sr s)), i:deliver(d), (σ', snd (netgmap sr s')))  trans (opnet onp n1)"
         and IH2: "s s' ζ. (s, i:deliver(d), s')  trans (pnet np n2)
                     netgmap sr s = netmask (net_tree_ips n2) (σ, ζ)
                     netgmap sr s' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s'))
                     s  reachable (pnet np n2) TT
                     wf_net_tree n2
                     inet_ips s
                     net_ip_action np (i:deliver(d)) i n2 s s'
                     ((σ, snd (netgmap sr s)), i:deliver(d), (σ', snd (netgmap sr s')))  trans (opnet onp n2)"
         and tr: "(s, i:deliver(d), s')  trans (pnet np (n1  n2))"
         and sr: "s  reachable (pnet np (n1  n2)) TT"
         and nm: "netgmap sr s = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
         and nm': "netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ', snd (netgmap sr s'))"
         and "wf_net_tree (n1  n2)"
         and "inet_ips s"
         and "net_ip_action np (i:deliver(d)) i (n1  n2) s s'"
      from tr have "(s, i:deliver(d), s')  pnet_sos (trans (pnet np n1)) (trans (pnet np n2))" by simp
      then obtain s1 s1' s2 s2' where "s = SubnetS s1 s2"
                                  and "s' = SubnetS s1' s2'"
        by (rule partial_deliverTE) auto
      from this(1) and nm have "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
        by simp
      from s' = SubnetS s1' s2' and nm'
        have "netgmap sr (SubnetS s1' s2') = netmask (net_tree_ips (n1  n2)) (σ', snd (netgmap sr s'))"
          by simp

      from ‹wf_net_tree (n1  n2) have "wf_net_tree n1"
                                    and "wf_net_tree n2"
                                    and "net_tree_ips n1  net_tree_ips n2 = {}" by auto

      from sr [simplified s = SubnetS s1 s2] have "s1  reachable (pnet np n1) TT"
        by (rule subnet_reachable(1))
      hence "net_ips s1 = net_tree_ips n1" by (rule pnet_net_ips_net_tree_ips)

      from sr [simplified s = SubnetS s1 s2] have "s2  reachable (pnet np n2) TT"
        by (rule subnet_reachable(2))
      hence "net_ips s2 = net_tree_ips n2" by (rule pnet_net_ips_net_tree_ips)

      from nm [simplified s = SubnetS s1 s2]
           ‹net_tree_ips n1  net_tree_ips n2 = {}
           ‹net_ips s1 = net_tree_ips n1
           ‹net_ips s2 = net_tree_ips n2 
        have "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
          by (rule netgmap_subnet_split1)

      from nm [simplified s = SubnetS s1 s2]
           ‹net_ips s1 = net_tree_ips n1
           ‹net_ips s2 = net_tree_ips n2 
        have "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
          by (rule netgmap_subnet_split2)

      from inet_ips s and s = SubnetS s1 s2 have "inet_ips s1  inet_ips s2" by auto
        thus "((σ, snd (netgmap sr s)), i:deliver(d), (σ', snd (netgmap sr s')))  trans (opnet onp (n1  n2))"
      proof
        assume "inet_ips s1"
        with s = SubnetS s1 s2 s' = SubnetS s1' s2' ‹net_ip_action np (i:deliver(d)) i (n1  n2) s s'
          have "(s1, i:deliver(d), s1')  trans (pnet np n1)"
           and "net_ip_action np (i:deliver(d)) i n1 s1 s1'"
           and "s2' = s2" by simp_all

        from ‹net_ips s1 = net_tree_ips n1 and (s1, i:deliver(d), s1')  trans (pnet np n1)
          have "net_ips s1' = net_tree_ips n1" by (metis pnet_maintains_dom)

        from nm' [simplified s' = SubnetS s1' s2' s2' = s2]
                        ‹net_tree_ips n1  net_tree_ips n2 = {}
                        ‹net_ips s1' = net_tree_ips n1
                        ‹net_ips s2 = net_tree_ips n2
          have "netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))"
            by (rule netgmap_subnet_split1)

        from (s1, i:deliver(d), s1')  trans (pnet np n1)
             ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))
             ‹netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))
             s1  reachable (pnet np n1) TT›
             ‹wf_net_tree n1
             inet_ips s1
             ‹net_ip_action np (i:deliver(d)) i n1 s1 s1'
          have "((σ, snd (netgmap sr s1)), i:deliver(d), (σ', snd (netgmap sr s1')))  trans (opnet onp n1)"
             by (rule IH1)

        with s = SubnetS s1 s2 s' = SubnetS s1' s2' s2' = s2 show ?thesis
          by simp (erule opnet_deliver1)
      next
        assume "inet_ips s2"
        with s = SubnetS s1 s2 s' = SubnetS s1' s2' ‹net_ip_action np (i:deliver(d)) i (n1  n2) s s'
          have "(s2, i:deliver(d), s2')  trans (pnet np n2)"
           and "net_ip_action np (i:deliver(d)) i n2 s2 s2'"
           and "s1' = s1" by simp_all

        from ‹net_ips s2 = net_tree_ips n2 and (s2, i:deliver(d), s2')  trans (pnet np n2)
          have "net_ips s2' = net_tree_ips n2" by (metis pnet_maintains_dom)

        from nm' [simplified s' = SubnetS s1' s2' s1' = s1]
                        ‹net_ips s1 = net_tree_ips n1
                        ‹net_ips s2' = net_tree_ips n2
          have "netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))"
            by (rule netgmap_subnet_split2)

        from (s2, i:deliver(d), s2')  trans (pnet np n2)
             ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))
             ‹netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))
             s2  reachable (pnet np n2) TT›
             ‹wf_net_tree n2
             inet_ips s2
             ‹net_ip_action np (i:deliver(d)) i n2 s2 s2'
          have "((σ, snd (netgmap sr s2)), i:deliver(d), (σ', snd (netgmap sr s2')))  trans (opnet onp n2)"
             by (rule IH2)

        with s = SubnetS s1 s2 s' = SubnetS s1' s2' s1' = s1 show ?thesis
          by simp (erule opnet_deliver2)
      qed
    qed
    with ζ = snd (netgmap sr s) have "((σ, ζ), i:deliver(d), (σ', snd (netgmap sr s')))  trans (opnet onp n)"
      by simp
    moreover from j. ji  σ' j = σ j i  net_ips s ζ = snd (netgmap sr s)
      have "j. jnet_ips ζ  σ' j = σ j" by (metis net_ips_netgmap)
    ultimately have "((σ, ζ), i:deliver(d), (σ', snd (netgmap sr s')))  trans (opnet onp n)
                      (j. jnet_ips ζ  σ' j = σ j)
                      netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))"
      using ‹netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s')) by simp
    thus "σ' ζ'. ((σ, ζ), i:deliver(d), (σ', ζ'))  trans (opnet onp n)
                   (j. jnet_ips ζ  σ' j = σ j)
                   netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')" by auto
  qed

lemma transfer_arrive':
  assumes "(s, H¬K:arrive(m), s')  trans (pnet np n)"
      and "s  reachable (pnet np n) TT"
      and "netgmap sr s  = netmask (net_tree_ips n) (σ, ζ)"
      and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
      and "wf_net_tree n"
  shows "((σ, ζ), H¬K:arrive(m), (σ', ζ'))  trans (opnet onp n)"
  proof -

    from assms(2) have "net_ips s = net_tree_ips n" ..
    with assms(1) have "net_ips s' = net_tree_ips n"
      by (metis pnet_maintains_dom)

    from ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "ζ = snd (netgmap sr s)" by simp

    from ‹netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')
      have "ζ' = snd (netgmap sr s')"
       and "netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))"
         by simp_all

    from assms(1-3) ‹netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s')) assms(5)
      have "((σ, snd (netgmap sr s)), H¬K:arrive(m), (σ', snd (netgmap sr s')))  trans (opnet onp n)"
      proof (induction n arbitrary: s s' ζ H K)
        fix ii Ri ns ns' ζ H K
        assume "(ns, H¬K:arrive(m), ns')  trans (pnet np ii; Ri)"
           and nsr: "ns  reachable (pnet np ii; Ri) TT"
           and "netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)"
           and "netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))"
        from this(1) have "(ns, H¬K:arrive(m), ns')  node_sos (trans (np ii))"
          by (simp add: node_comps)
        moreover with nsr obtain s s' R where "ns  = NodeS ii s R"
                                          and "ns' = NodeS ii s' R"
          by (metis net_node_reachable_is_node node_arriveTE')
        ultimately have "(NodeS ii s R, H¬K:arrive(m), NodeS ii s' R)  node_sos (trans (np ii))"
          by simp
        from this(1) have "((σ, NodeS ii (snd (sr s)) R), H¬K:arrive(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
        proof (rule node_arriveTE)
          assume "(s, receive m, s')  trans (np ii)"
             and "H = {ii}"
             and "K = {}"
          from ‹netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ) and ns  = NodeS ii s R
            have "σ ii = fst (sr s)"
              by simp (metis map_upd_Some_unfold)
          moreover from ‹netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))
                        and ns' = NodeS ii s' R
            have "σ' ii = fst (sr s')" by simp (metis map_upd_Some_unfold)
          ultimately have "((σ, snd (sr s)), receive m, (σ', snd (sr s')))  trans (onp ii)"
            using (s, receive m, s')  trans (np ii) by (rule trans)
          hence "((σ, NodeS ii (snd (sr s)) R), {ii}¬{}:arrive(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
            by (rule onode_receive)
          with H={ii} and K={}
            show "((σ, NodeS ii (snd (sr s)) R), H¬K:arrive(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
              by simp
        next
          assume "H = {}"
             and "s' = s"
             and "K = {ii}"
          from s' = s ‹netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))
                        ‹netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)
                        ns = NodeS ii s R and ns' = NodeS ii s' R
            have "σ' ii = σ ii" by simp (metis option.sel)
          hence "((σ, NodeS ii (snd (sr s)) R), {}¬{ii}:arrive(m), (σ', NodeS ii (snd (sr s)) R))
                                                                       onode_sos (trans (onp ii))"
            by (rule onode_arrive)
          with H={} K={ii} and s' = s
          show "((σ, NodeS ii (snd (sr s)) R), H¬K:arrive(m), (σ', NodeS ii (snd (sr s')) R))
                                                                      onode_sos (trans (onp ii))"
            by simp
        qed
      with ns = NodeS ii s R ns' = NodeS ii s' R
        show "((σ, snd (netgmap sr ns)), H¬K:arrive(m), (σ', snd (netgmap sr ns')))
                                                              trans (opnet onp ii; Ri)"
          by (simp add: onode_comps)
    next
      fix n1 n2 s s' ζ H K
      assume IH1: "s s' ζ H K. (s, H¬K:arrive(m), s')  trans (pnet np n1)
                          s  reachable (pnet np n1) TT
                          netgmap sr s = netmask (net_tree_ips n1) (σ, ζ)
                          netgmap sr s' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s'))
                          wf_net_tree n1
                          ((σ, snd (netgmap sr s)), H¬K:arrive(m), σ', snd (netgmap sr s'))
                                                                         trans (opnet onp n1)"
        and IH2: "s s' ζ H K. (s, H¬K:arrive(m), s')  trans (pnet np n2)
                          s  reachable (pnet np n2) TT
                          netgmap sr s = netmask (net_tree_ips n2) (σ, ζ)
                          netgmap sr s' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s'))
                          wf_net_tree n2
                          ((σ, snd (netgmap sr s)), H¬K:arrive(m), σ', snd (netgmap sr s'))
                                                                         trans (opnet onp n2)"
        and "(s, H¬K:arrive(m), s')  trans (pnet np (n1  n2))"
        and sr: "s  reachable (pnet np (n1  n2)) TT"
        and nm: "netgmap sr s = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
        and nm': "netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ', snd (netgmap sr s'))"
        and "wf_net_tree (n1  n2)"
      from this(3) have "(s, H¬K:arrive(m), s')  pnet_sos (trans (pnet np n1))
                                                              (trans (pnet np n2))"
        by simp
      thus "((σ, snd (netgmap sr s)), H¬K:arrive(m), (σ', snd (netgmap sr s')))
                                                                    trans (opnet onp (n1  n2))"
      proof (rule partial_arriveTE)
        fix s1 s1' s2 s2' H1 H2 K1 K2
        assume "s = SubnetS s1 s2"
           and "s' = SubnetS s1' s2'"
           and tr1: "(s1, H1¬K1:arrive(m), s1')  trans (pnet np n1)"
           and tr2: "(s2, H2¬K2:arrive(m), s2')  trans (pnet np n2)"
           and "H = H1  H2"
           and "K = K1  K2"

        from ‹wf_net_tree (n1  n2) have "wf_net_tree n1"
                                      and "wf_net_tree n2"
                                      and "net_tree_ips n1  net_tree_ips n2 = {}" by auto

        from sr [simplified s = SubnetS s1 s2] have "s1  reachable (pnet np n1) TT"
          by (rule subnet_reachable(1))
        hence "net_ips s1 = net_tree_ips n1" by (rule pnet_net_ips_net_tree_ips)
        with tr1 have "net_ips s1' = net_tree_ips n1" by (metis pnet_maintains_dom)

        from sr [simplified s = SubnetS s1 s2] have "s2  reachable (pnet np n2) TT"
          by (rule subnet_reachable(2))
        hence "net_ips s2 = net_tree_ips n2" by (rule pnet_net_ips_net_tree_ips)
        with tr2 have "net_ips s2' = net_tree_ips n2" by (metis pnet_maintains_dom)

        from (s1, H1¬K1:arrive(m), s1')  trans (pnet np n1)
             s1  reachable (pnet np n1) TT›
          have "((σ, snd (netgmap sr s1)), H1¬K1:arrive(m), (σ', snd (netgmap sr s1')))
                                                                             trans (opnet onp n1)"
          proof (rule IH1 [OF _ _ _ _ ‹wf_net_tree n1])
            from nm [simplified s = SubnetS s1 s2]
                 ‹net_tree_ips n1  net_tree_ips n2 = {}
                 ‹net_ips s1 = net_tree_ips n1
                 ‹net_ips s2 = net_tree_ips n2 
              show "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
                by (rule netgmap_subnet_split1)
          next
            from nm' [simplified s' = SubnetS s1' s2']
                 ‹net_tree_ips n1  net_tree_ips n2 = {}
                 ‹net_ips s1' = net_tree_ips n1
                 ‹net_ips s2' = net_tree_ips n2 
              show "netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))"
                by (rule netgmap_subnet_split1)
          qed

        moreover from (s2, H2¬K2:arrive(m), s2')  trans (pnet np n2)
                      s2  reachable (pnet np n2) TT›
          have "((σ, snd (netgmap sr s2)), H2¬K2:arrive(m), (σ', snd (netgmap sr s2')))
                                                                             trans (opnet onp n2)"
          proof (rule IH2 [OF _ _ _ _ ‹wf_net_tree n2])
            from nm [simplified s = SubnetS s1 s2]
                 ‹net_ips s1 = net_tree_ips n1
                 ‹net_ips s2 = net_tree_ips n2 
              show "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
                by (rule netgmap_subnet_split2)
          next
            from nm' [simplified s' = SubnetS s1' s2']
                 ‹net_ips s1' = net_tree_ips n1
                 ‹net_ips s2' = net_tree_ips n2 
              show "netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))"
                by (rule netgmap_subnet_split2)
          qed
        ultimately show "((σ, snd (netgmap sr s)), H¬K:arrive(m), (σ', snd (netgmap sr s')))
                                                                      trans (opnet onp (n1  n2))"
          using s = SubnetS s1 s2 s' = SubnetS s1' s2' H = H1  H2 K = K1  K2
            by simp (rule opnet_sos.opnet_arrive)
      qed
    qed
    with ζ = snd (netgmap sr s) and ζ' = snd (netgmap sr s')
      show "((σ, ζ), H¬K:arrive(m), (σ', ζ'))  trans (opnet onp n)"
        by simp
  qed

lemma transfer_arrive:
  assumes "(s, H¬K:arrive(m), s')  trans (pnet np n)"
      and "s  reachable (pnet np n) TT"
      and "netgmap sr s  = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
  obtains σ' ζ' where "((σ, ζ), H¬K:arrive(m), (σ', ζ'))  trans (opnet onp n)"
                  and "j. jnet_ips ζ  σ' j = σ j"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    define σ' where "σ' i = (if inet_tree_ips n then the (fst (netgmap sr s') i) else σ i)" for i

    from assms(2) have "net_ips s = net_tree_ips n"
      by (rule pnet_net_ips_net_tree_ips)
    with assms(1) have "net_ips s' = net_tree_ips n"
      by (metis pnet_maintains_dom)

    have "netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))"
    proof (rule prod_eqI)
      from ‹net_ips s' = net_tree_ips n
        show "fst (netgmap sr s') = fst (netmask (net_tree_ips n) (σ', snd (netgmap sr s')))"
          unfolding σ'_def [abs_def] by - (rule ext, clarsimp)
    qed simp

    moreover with assms(1-3)
    have "((σ, ζ), H¬K:arrive(m), (σ', snd (netgmap sr s')))  trans (opnet onp n)"
      using ‹wf_net_tree n by (rule transfer_arrive')

    moreover have "j. jnet_ips ζ  σ' j = σ j"
    proof -
      have "j. jnet_tree_ips n  σ' j = σ j" unfolding σ'_def by simp
      with assms(3) and ‹net_ips s = net_tree_ips n
        show ?thesis
          by clarsimp (metis (mono_tags) net_ips_netgmap snd_conv)
    qed

    ultimately show "σ' ζ'. ((σ, ζ), H¬K:arrive(m), (σ', ζ'))  trans (opnet onp n)
                           (j. jnet_ips ζ  σ' j = σ j)
                           netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')" by auto
  qed

lemma transfer_cast:
  assumes "(s, mR:*cast(m), s')  trans (pnet np n)"
      and "s  reachable (pnet np n) TT"
      and "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
  obtains σ' ζ' where "((σ, ζ), mR:*cast(m), (σ', ζ'))  trans (opnet onp n)"
                  and "j. jnet_ips ζ  σ' j = σ j"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    define σ' where "σ' i = (if inet_tree_ips n then the (fst (netgmap sr s') i) else σ i)" for i

    from assms(2) have "net_ips s = net_tree_ips n" ..
    with assms(1) have "net_ips s' = net_tree_ips n"
      by (metis pnet_maintains_dom)
    have "netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))"
    proof (rule prod_eqI)
      from ‹net_ips s' = net_tree_ips n
        show "fst (netgmap sr s') = fst (netmask (net_tree_ips n) (σ', snd (netgmap sr s')))"
      unfolding σ'_def [abs_def] by - (rule ext, clarsimp simp add: some_the_fst_netgmap)
    qed simp

    from ‹net_ips s' = net_tree_ips n and ‹net_ips s = net_tree_ips n 
      have "j. jnet_ips (snd (netgmap sr s))  σ' j = σ j"
        unfolding σ'_def by simp

    from ‹netgmap sr s = netmask (net_tree_ips n) (σ, ζ)
      have "ζ = snd (netgmap sr s)" by simp

    from assms(1-3) ‹netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s')) assms(4)
      have "((σ, snd (netgmap sr s)), mR:*cast(m), (σ', snd (netgmap sr s')))  trans (opnet onp n)"
      proof (induction n arbitrary: s s' ζ mR)
        fix ii Ri ns ns' ζ mR
        assume "(ns, mR:*cast(m), ns')  trans (pnet np ii; Ri)"
           and nsr: "ns  reachable (pnet np ii; Ri) TT"
           and "netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ)"
           and "netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))"
        from this(1) have "(ns, mR:*cast(m), ns')  node_sos (trans (np ii))"
          by (simp add: node_comps)
        moreover with nsr obtain s s' R where "ns  = NodeS ii s R"
                                          and "ns' = NodeS ii s' R"
          by (metis net_node_reachable_is_node node_castTE')
        ultimately have "(NodeS ii s R, mR:*cast(m), NodeS ii s' R)  node_sos (trans (np ii))"
          by simp

        from ‹netgmap sr ns = netmask (net_tree_ips ii; Ri) (σ, ζ) and ns  = NodeS ii s R
          have "σ ii = fst (sr s)"
            by simp (metis map_upd_Some_unfold)
        from ‹netgmap sr ns' = netmask (net_tree_ips ii; Ri) (σ', snd (netgmap sr ns'))
             and ns' = NodeS ii s' R
          have "σ' ii = fst (sr s')" by simp (metis map_upd_Some_unfold)

        from (NodeS ii s R, mR:*cast(m), NodeS ii s' R)  node_sos (trans (np ii))
          have "((σ, NodeS ii (snd (sr s)) R), mR:*cast(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
        proof (rule node_castTE)
          assume "(s, broadcast m, s')  trans (np ii)"
             and "mR = R"
          from σ ii = fst (sr s) σ' ii = fst (sr s') and this(1)
            have "((σ, snd (sr s)), broadcast m, (σ', snd (sr s')))  trans (onp ii)"
              by (rule trans)
          hence "((σ, NodeS ii (snd (sr s)) R), R:*cast(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
            by (rule onode_bcast)
          with mR = R show "((σ, NodeS ii (snd (sr s)) R), mR:*cast(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
              by simp
        next
          fix D
          assume "(s, groupcast D m, s')  trans (np ii)"
             and "mR = R  D"
          from σ ii = fst (sr s) σ' ii = fst (sr s') and this(1)
            have "((σ, snd (sr s)), groupcast D m, (σ', snd (sr s')))  trans (onp ii)"
              by (rule trans)
          hence "((σ, NodeS ii (snd (sr s)) R), (R  D):*cast(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
            by (rule onode_gcast)
          with mR = R  D show "((σ, NodeS ii (snd (sr s)) R), mR:*cast(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
              by simp
        next
          fix d
          assume "(s, unicast d m, s')  trans (np ii)"
             and "d  R"
             and "mR = {d}"
          from σ ii = fst (sr s) σ' ii = fst (sr s') and this(1)
            have "((σ, snd (sr s)), unicast d m, (σ', snd (sr s')))  trans (onp ii)"
              by (rule trans)
          hence "((σ, NodeS ii (snd (sr s)) R), {d}:*cast(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
            using dR by (rule onode_ucast)
          with mR={d} show "((σ, NodeS ii (snd (sr s)) R), mR:*cast(m), (σ', NodeS ii (snd (sr s')) R))
                                                                       onode_sos (trans (onp ii))"
            by simp
        qed
      with ns = NodeS ii s R ns' = NodeS ii s' R
        show "((σ, snd (netgmap sr ns)), mR:*cast(m), (σ', snd (netgmap sr ns')))
                                                              trans (opnet onp ii; Ri)"
          by (simp add: onode_comps)
    next
      fix n1 n2 s s' ζ mR
      assume IH1: "s s' ζ mR. (s, mR:*cast(m), s')  trans (pnet np n1)
                          s  reachable (pnet np n1) TT
                          netgmap sr s = netmask (net_tree_ips n1) (σ, ζ)
                          netgmap sr s' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s'))
                          wf_net_tree n1
                          ((σ, snd (netgmap sr s)), mR:*cast(m), σ', snd (netgmap sr s'))
                                                                         trans (opnet onp n1)"
        and IH2: "s s' ζ mR. (s, mR:*cast(m), s')  trans (pnet np n2)
                          s  reachable (pnet np n2) TT
                          netgmap sr s = netmask (net_tree_ips n2) (σ, ζ)
                          netgmap sr s' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s'))
                          wf_net_tree n2
                          ((σ, snd (netgmap sr s)), mR:*cast(m), σ', snd (netgmap sr s'))
                                                                         trans (opnet onp n2)"
        and "(s, mR:*cast(m), s')  trans (pnet np (n1  n2))"
        and sr: "s  reachable (pnet np (n1  n2)) TT"
        and nm: "netgmap sr s = netmask (net_tree_ips (n1  n2)) (σ, ζ)"
        and nm': "netgmap sr s' = netmask (net_tree_ips (n1  n2)) (σ', snd (netgmap sr s'))"
        and "wf_net_tree (n1  n2)"
      from this(3) have "(s, mR:*cast(m), s')  pnet_sos (trans (pnet np n1)) (trans (pnet np n2))"
        by simp
      then obtain s1 s1' s2 s2' H K
        where "s  = SubnetS s1  s2"
          and "s' = SubnetS s1' s2'"
          and "H  mR"
          and "K  mR = {}"
          and trtr: "((s1, mR:*cast(m), s1')  trans (pnet np n1)
                                   (s2, H¬K:arrive(m), s2')  trans (pnet np n2))
                     ((s1, H¬K:arrive(m), s1')  trans (pnet np n1)
                                   (s2, mR:*cast(m), s2')  trans (pnet np n2))"
          by (rule partial_castTE) metis+

      from ‹wf_net_tree (n1  n2) have "wf_net_tree n1"
                                    and "wf_net_tree n2"
                                    and "net_tree_ips n1  net_tree_ips n2 = {}" by auto

      from sr [simplified s = SubnetS s1 s2] have "s1  reachable (pnet np n1) TT"
        by (rule subnet_reachable(1))
      hence "net_ips s1 = net_tree_ips n1" by (rule pnet_net_ips_net_tree_ips)
      with trtr have "net_ips s1' = net_tree_ips n1" by (metis pnet_maintains_dom)

      from sr [simplified s = SubnetS s1 s2] have "s2  reachable (pnet np n2) TT"
        by (rule subnet_reachable(2))
      hence "net_ips s2 = net_tree_ips n2" by (rule pnet_net_ips_net_tree_ips)
      with trtr have "net_ips s2' = net_tree_ips n2" by (metis pnet_maintains_dom)

      from nm [simplified s = SubnetS s1 s2]
           ‹net_tree_ips n1  net_tree_ips n2 = {}
           ‹net_ips s1 = net_tree_ips n1
           ‹net_ips s2 = net_tree_ips n2 
        have "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
          by (rule netgmap_subnet_split1)

      from nm' [simplified s' = SubnetS s1' s2']
           ‹net_tree_ips n1  net_tree_ips n2 = {}
           ‹net_ips s1' = net_tree_ips n1
           ‹net_ips s2' = net_tree_ips n2 
        have "netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))"
          by (rule netgmap_subnet_split1)

      from nm [simplified s = SubnetS s1 s2]
           ‹net_ips s1 = net_tree_ips n1
           ‹net_ips s2 = net_tree_ips n2 
        have "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
          by (rule netgmap_subnet_split2)

      from nm' [simplified s' = SubnetS s1' s2']
           ‹net_ips s1' = net_tree_ips n1
           ‹net_ips s2' = net_tree_ips n2 
        have "netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))"
          by (rule netgmap_subnet_split2)

      from trtr show "((σ, snd (netgmap sr s)), mR:*cast(m), (σ', snd (netgmap sr s')))
                                                               trans (opnet onp (n1  n2))"
      proof (elim disjE conjE)
        assume "(s1, mR:*cast(m), s1')  trans (pnet np n1)"
           and "(s2, H¬K:arrive(m), s2')  trans (pnet np n2)"
        from (s1, mR:*cast(m), s1')  trans (pnet np n1)
             s1  reachable (pnet np n1) TT›
             ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))
             ‹netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))
             ‹wf_net_tree n1
          have "((σ, snd (netgmap sr s1)), mR:*cast(m), (σ', snd (netgmap sr s1')))  trans (opnet onp n1)"
            by (rule IH1)

        moreover from (s2, H¬K:arrive(m), s2')  trans (pnet np n2)
             s2  reachable (pnet np n2) TT›
             ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))
             ‹netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))
             ‹wf_net_tree n2
          have "((σ, snd (netgmap sr s2)), H¬K:arrive(m), (σ', snd (netgmap sr s2')))  trans (opnet onp n2)"
            by (rule transfer_arrive')

        ultimately have "((σ, SubnetS (snd (netgmap sr s1)) (snd (netgmap sr s2))), mR:*cast(m),
                          (σ', SubnetS (snd (netgmap sr s1')) (snd (netgmap sr s2'))))
                              opnet_sos (trans (opnet onp n1)) (trans (opnet onp n2))"
          using H  mR and K  mR = {} by (rule opnet_sos.intros(1))
        with s = SubnetS s1 s2 s' = SubnetS s1' s2' show ?thesis by simp
      next
        assume "(s1, H¬K:arrive(m), s1')  trans (pnet np n1)"
           and "(s2, mR:*cast(m), s2')  trans (pnet np n2)"
        from (s1, H¬K:arrive(m), s1')  trans (pnet np n1)
             s1  reachable (pnet np n1) TT›
             ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))
             ‹netgmap sr s1' = netmask (net_tree_ips n1) (σ', snd (netgmap sr s1'))
             ‹wf_net_tree n1
          have "((σ, snd (netgmap sr s1)), H¬K:arrive(m), (σ', snd (netgmap sr s1')))  trans (opnet onp n1)"
            by (rule transfer_arrive')

        moreover from (s2, mR:*cast(m), s2')  trans (pnet np n2)
             s2  reachable (pnet np n2) TT›
             ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))
             ‹netgmap sr s2' = netmask (net_tree_ips n2) (σ', snd (netgmap sr s2'))
             ‹wf_net_tree n2
          have "((σ, snd (netgmap sr s2)), mR:*cast(m), (σ', snd (netgmap sr s2')))  trans (opnet onp n2)"
            by (rule IH2)

        ultimately have "((σ, SubnetS (snd (netgmap sr s1)) (snd (netgmap sr s2))), mR:*cast(m),
                          (σ', SubnetS (snd (netgmap sr s1')) (snd (netgmap sr s2'))))
                              opnet_sos (trans (opnet onp n1)) (trans (opnet onp n2))"
          using H  mR and K  mR = {} by (rule opnet_sos.intros(2))
        with s = SubnetS s1 s2 s' = SubnetS s1' s2' show ?thesis by simp
      qed
    qed
    with ζ = snd (netgmap sr s) have "((σ, ζ), mR:*cast(m), (σ', snd (netgmap sr s')))  trans (opnet onp n)"
      by simp
    moreover from j. jnet_ips (snd (netgmap sr s))  σ' j = σ j ζ = snd (netgmap sr s)
      have "j. jnet_ips ζ  σ' j = σ j" by simp
    moreover note ‹netgmap sr s' = netmask (net_tree_ips n) (σ', snd (netgmap sr s'))
    ultimately show "σ' ζ'. ((σ, ζ), mR:*cast(m), (σ', ζ'))  trans (opnet onp n)
                            (j. jnet_ips ζ  σ' j = σ j)
                            netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
      by auto
  qed

lemma transfer_pnet_action:
  assumes "s  reachable (pnet np n) TT"
      and "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
      and "(s, a, s')  trans (pnet np n)"
  obtains σ' ζ' where "((σ, ζ), a, (σ', ζ'))  trans (opnet onp n)"
                  and "j. jnet_ips ζ  σ' j = σ j"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    show "σ' ζ'. ((σ, ζ), a, (σ', ζ'))  trans (opnet onp n)
                   (j. jnet_ips ζ  σ' j = σ j)
                   netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
    proof (cases a)
      case node_cast
      with assms(4) show ?thesis
        by (auto elim!: transfer_cast [OF _ assms(1-3)])
    next
      case node_deliver
      with assms(4) show ?thesis
        by (auto elim!: transfer_deliver [OF _ assms(1-3)])
    next
      case node_arrive
      with assms(4) show ?thesis
        by (auto elim!: transfer_arrive [OF _ assms(1-3)])
    next
      case node_connect
      with assms(4) show ?thesis
        by (auto elim!: transfer_connect [OF _ assms(1-3)])
    next
      case node_disconnect
      with assms(4) show ?thesis
        by (auto elim!: transfer_disconnect [OF _ assms(1-3)])
    next
      case node_newpkt
      with assms(4) have False by (metis pnet_never_newpkt)
      thus ?thesis ..
    next
      case node_tau
      with assms(4) show ?thesis
        by (auto elim!: transfer_tau [OF _ assms(1-3), simplified])
    qed
  qed

lemma transfer_action_pnet_closed:
  assumes "(s, a, s')  trans (closed (pnet np n))"
  obtains a' where "(s, a', s')  trans (pnet np n)"
               and "σ ζ σ' ζ'.  ((σ, ζ), a', (σ', ζ'))  trans (opnet onp n);
                                  (j. jnet_ips ζ  σ' j = σ j) 
                             ((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n))"
  proof (atomize_elim)
    from assms have "(s, a, s')  cnet_sos (trans (pnet np n))" by simp
    thus "a'. (s, a', s')  trans (pnet np n)
                 (σ ζ σ' ζ'. ((σ, ζ), a', (σ', ζ'))  trans (opnet onp n)
                                (j. j  net_ips ζ  σ' j = σ j)
                                ((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n)))"
    proof cases
      case (cnet_cast R m) thus ?thesis
      by (auto intro!: exI [where x="R:*cast(m)"] dest!: ocnet_cast)
    qed (auto intro!: ocnet_sos.intros [simplified])
  qed

lemma transfer_action:
  assumes "s  reachable (closed (pnet np n)) TT"
      and "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
      and "wf_net_tree n"
      and "(s, a, s')  trans (closed (pnet np n))"
  obtains σ' ζ' where "((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n))"
                  and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
  proof atomize_elim
    from assms(1) have "s  reachable (pnet np n) TT" ..
    from assms(4)
      show "σ' ζ'. ((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n))
                     netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
        by (cases a)
           ((elim transfer_action_pnet_closed
                  transfer_pnet_action [OF s  reachable (pnet np n) TT› assms(2-3)])?,
            (auto intro!: exI)[1])+
  qed

lemma pnet_reachable_transfer':
  assumes "wf_net_tree n"
      and "s  reachable (closed (pnet np n)) TT"
    shows "netgmap sr s  netmask (net_tree_ips n) ` oreachable (oclosed (opnet onp n)) (λ_ _ _. True) U"
          (is " _  ?f ` ?oreachable n")
  using assms(2) proof induction
    fix s
    assume "s  init (closed (pnet np n))"
    hence "s  init (pnet np n)" by simp
    with ‹wf_net_tree n have "netgmap sr s  netmask (net_tree_ips n) ` init (opnet onp n)"
      by (rule init_pnet_opnet)
    hence "netgmap sr s  netmask (net_tree_ips n) ` init (oclosed (opnet onp n))"
      by simp
    moreover have "netmask (net_tree_ips n) ` init (oclosed (opnet onp n))
                                         netmask (net_tree_ips n) ` ?oreachable n"
      by (intro image_mono subsetI) (rule oreachable_init)
    ultimately show "netgmap sr s  netmask (net_tree_ips n) ` ?oreachable n"
      by (rule rev_subsetD)
  next
    fix s a s'
    assume "s  reachable (closed (pnet np n)) TT"
       and "netgmap sr s  netmask (net_tree_ips n) ` ?oreachable n"
       and "(s, a, s')  trans (closed (pnet np n))"
    from this(2) obtain σ ζ where "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
                              and "(σ, ζ)  ?oreachable n"
      by clarsimp
    from s  reachable (closed (pnet np n)) TT› this(1) ‹wf_net_tree n
         and (s, a, s')  trans (closed (pnet np n))
      obtain σ' ζ' where "((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n))"
                     and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
        by (rule transfer_action)
    from (σ, ζ)  ?oreachable n and this(1) have "(σ', ζ')  ?oreachable n"
      by (rule oreachable_local) simp
    with ‹netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')
      show "netgmap sr s'  netmask (net_tree_ips n) ` ?oreachable n" by (rule image_eqI)
  qed

definition
  someinit :: "nat  'g"
where
  "someinit i  SOME x. x  (fst o sr) ` init (np i)"

definition
  initmissing :: "((nat  'g option) × 'a)  (nat  'g) × 'a"
where
  "initmissing σ = (λi. case (fst σ) i of None  someinit i | Some s  s, snd σ)"

lemma initmissing_def':
  "initmissing = apfst (default someinit)"
  by (auto simp add: initmissing_def default_def)

lemma netmask_initmissing_netgmap:
  "netmask (net_ips s) (initmissing (netgmap sr s)) = netgmap sr s"
  proof (intro prod_eqI ext)
    fix i
    show "fst (netmask (net_ips s) (initmissing (netgmap sr s))) i = fst (netgmap sr s) i"
      unfolding initmissing_def by (clarsimp split: option.split)
  qed (simp add: initmissing_def)

lemma snd_initmissing [simp]:
  "snd (initmissing x)= snd x"
  unfolding initmissing_def by simp

lemma initmnissing_snd_netgmap [simp]:
  assumes "initmissing (netgmap sr s) = (σ, ζ)"
    shows "snd (netgmap sr s) = ζ"
  using assms unfolding initmissing_def by simp


lemma in_net_ips_fst_init_missing [simp]:
  assumes "i  net_ips s"
    shows "fst (initmissing (netgmap sr s)) i = the (fst (netgmap sr s) i)"
  using assms unfolding initmissing_def by (clarsimp split: option.split)

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i  net_ips s"
    shows "fst (initmissing (netgmap sr s)) i = someinit i"
  using assms unfolding initmissing_def by (clarsimp split: option.split)

lemma initmissing_oreachable_netmask [elim]:
  assumes "initmissing (netgmap sr s)  oreachable (oclosed (opnet onp n)) (λ_ _ _. True) U"
          (is "_  ?oreachable n")
      and "net_ips s = net_tree_ips n"
    shows "netgmap sr s  netmask (net_tree_ips n) ` ?oreachable n"
  proof -
    obtain σ ζ where "initmissing (netgmap sr s) = (σ, ζ)" by (metis surj_pair)
    with assms(1) have "(σ, ζ)  ?oreachable n" by simp

    have "netgmap sr s = netmask (net_ips s) (σ, ζ)"
    proof (intro prod_eqI ext)
      fix i
      show "fst (netgmap sr s) i = fst (netmask (net_ips s) (σ, ζ)) i"
      proof (cases "inet_ips s")
        assume "inet_ips s"
        hence "fst (initmissing (netgmap sr s)) i = the (fst (netgmap sr s) i)"
          by (rule in_net_ips_fst_init_missing)
        moreover from inet_ips s have "Some (the (fst (netgmap sr s) i)) = fst (netgmap sr s) i"
          by (rule some_the_fst_netgmap)
        ultimately show ?thesis
          using ‹initmissing (netgmap sr s) = (σ, ζ) by simp
      qed simp
    next
      from ‹initmissing (netgmap sr s) = (σ, ζ)
        show "snd (netgmap sr s) = snd (netmask (net_ips s) (σ, ζ))"
          by simp
    qed
    with assms(2) have "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)" by simp
    moreover from (σ, ζ)  ?oreachable n
      have "netmask (net_ips s) (σ, ζ)  netmask (net_ips s) ` ?oreachable n"
        by (rule imageI)
    ultimately show ?thesis
      by (simp only: assms(2))
  qed

lemma pnet_reachable_transfer:
  assumes "wf_net_tree n"
      and "s  reachable (closed (pnet np n)) TT"
    shows "initmissing (netgmap sr s)  oreachable (oclosed (opnet onp n)) (λ_ _ _. True) U"
          (is " _  ?oreachable n")
  using assms(2) proof induction
    fix s
    assume "s  init (closed (pnet np n))"
    hence "s  init (pnet np n)" by simp

    from ‹wf_net_tree n have "initmissing (netgmap sr s)  init (opnet onp n)"
    proof (rule init_lifted [THEN subsetD], intro CollectI exI conjI allI)
      show "initmissing (netgmap sr s) = (fst (initmissing (netgmap sr s)), snd (netgmap sr s))"
        by (metis snd_initmissing surjective_pairing)
    next
      from s  init (pnet np n) show "s  init (pnet np n)" ..
    next
      fix i
      show "if i  net_tree_ips n
            then (fst (initmissing (netgmap sr s))) i = the (fst (netgmap sr s) i)
            else (fst (initmissing (netgmap sr s))) i  (fst  sr) ` init (np i)"
      proof (cases "i  net_tree_ips n", simp_all only: if_True if_False)
        assume "i  net_tree_ips n"
        with s  init (pnet np n) have "i  net_ips s" ..
        thus "fst (initmissing (netgmap sr s)) i = the (fst (netgmap sr s) i)" by simp
      next
        assume "i  net_tree_ips n"
        with s  init (pnet np n) have "i  net_ips s" ..
        hence "fst (initmissing (netgmap sr s)) i = someinit i" by simp
        moreover have "someinit i  (fst  sr) ` init (np i)"
        unfolding someinit_def proof (rule someI_ex)
          from init_notempty show "x. x  (fst o sr) ` init (np i)" by auto
        qed
        ultimately show "fst (initmissing (netgmap sr s)) i  (fst  sr) ` init (np i)"
          by simp
      qed
    qed
    hence "initmissing (netgmap sr s)  init (oclosed (opnet onp n))" by simp
    thus "initmissing (netgmap sr s)  ?oreachable n" ..
  next
    fix s a s'
    assume "s  reachable (closed (pnet np n)) TT"
       and "(s, a, s')  trans (closed (pnet np n))"
       and "initmissing (netgmap sr s)  ?oreachable n"
    from this(1) have "s  reachable (pnet np n) TT" ..
    hence "net_ips s = net_tree_ips n" by (rule pnet_net_ips_net_tree_ips)
    with ‹initmissing (netgmap sr s)  ?oreachable n
      have "netgmap sr s  netmask (net_tree_ips n) ` ?oreachable n"
        by (rule initmissing_oreachable_netmask)

    obtain σ ζ where "(σ, ζ) = initmissing (netgmap sr s)" by (metis surj_pair)
    with ‹initmissing (netgmap sr s)  ?oreachable n
      have "(σ, ζ)  ?oreachable n" by simp
    from (σ, ζ) = initmissing (netgmap sr s) and ‹net_ips s = net_tree_ips n [symmetric]
      have "netgmap sr s = netmask (net_tree_ips n) (σ, ζ)"
        by (clarsimp simp add: netmask_initmissing_netgmap)

    with s  reachable (closed (pnet np n)) TT›
      obtain σ' ζ' where "((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n))"
                     and "netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')"
        using ‹wf_net_tree n and (s, a, s')  trans (closed (pnet np n))
        by (rule transfer_action)

    from (σ, ζ)  ?oreachable n have "net_ips ζ = net_tree_ips n"
      by (rule opnet_net_ips_net_tree_ips [OF oclosed_oreachable_oreachable])
    with ((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n))
      have "j. jnet_tree_ips n  σ' j = σ j"
        by (clarsimp elim!: ocomplete_no_change)
    have "initmissing (netgmap sr s') = (σ', ζ')"
    proof (intro prod_eqI ext)
      fix i
      from ‹netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')
           j. jnet_tree_ips n  σ' j = σ j
           (σ, ζ) = initmissing (netgmap sr s)
           ‹net_ips s = net_tree_ips n
      show "fst (initmissing (netgmap sr s')) i = fst (σ', ζ') i"
        unfolding initmissing_def by simp
    next
      from ‹netgmap sr s' = netmask (net_tree_ips n) (σ', ζ')
        show "snd (initmissing (netgmap sr s')) = snd (σ', ζ')" by simp
    qed
    moreover from (σ, ζ)  ?oreachable n ((σ, ζ), a, (σ', ζ'))  trans (oclosed (opnet onp n))
      have "(σ', ζ')  ?oreachable n"
        by (rule oreachable_local) (rule TrueI)

    ultimately show "initmissing (netgmap sr s')  ?oreachable n"
      by simp
  qed

definition
  netglobal :: "((nat  'g)  bool)  's net_state  bool"
where
  "netglobal P  (λs. P (fst (initmissing (netgmap sr s))))"

lemma netglobalsimp [simp]:
  "netglobal P s = P (fst (initmissing (netgmap sr s)))"
  unfolding netglobal_def by simp

lemma netglobalE [elim]:
  assumes "netglobal P s"
      and "σ.  P σ; fst (initmissing (netgmap sr s)) = σ   Q σ"
    shows "netglobal Q s"
  using assms by simp

lemma netglobal_weakenE [elim]:
  assumes "p  netglobal P"
      and "σ. P σ  Q σ"
    shows "p  netglobal Q"
  using assms(1) proof (rule invariant_weakenE)
    fix s
    assume "netglobal P s"
    thus "netglobal Q s"
      by (rule netglobalE) (erule assms(2))
  qed

lemma close_opnet:
  assumes "wf_net_tree n"
      and "oclosed (opnet onp n)  (λ_ _ _. True, U →) global P"
    shows "closed (pnet np n)  netglobal P"
  unfolding invariant_def proof
    fix s
    assume "s  reachable (closed (pnet np n)) TT"
    with assms(1)
      have "initmissing (netgmap sr s)  oreachable (oclosed (opnet onp n)) (λ_ _ _. True) U"
        by (rule pnet_reachable_transfer)
    with assms(2) have "global P (initmissing (netgmap sr s))" ..
    thus "netglobal P s" by simp
  qed

end

locale openproc_parq =
  op?: openproc np onp sr for np :: "ip  ('s, ('m::msg) seq_action) automaton" and onp sr
  + fixes qp :: "('t, 'm seq_action) automaton"
    assumes init_qp_notempty: "init qp  {}"

sublocale openproc_parq  openproc "λi. np i ⟨⟨ qp"
                                   "λi. onp i ⟨⟨i qp"
                                   "λ(p, q). (fst (sr p), (snd (sr p), q))"
  proof unfold_locales
    fix i
    show "{ (σ, ζ) |σ ζ s. s  init (np i ⟨⟨ qp)
                          (σ i, ζ) = ((λ(p, q). (fst (sr p), (snd (sr p), q))) s)
                          (j. ji  σ j  (fst o (λ(p, q). (fst (sr p), (snd (sr p), q))))
                                                  ` init (np j ⟨⟨ qp)) }  init (onp i ⟨⟨i qp)"
       (is "?S  _")
    proof
      fix s
      assume "s  ?S"
      then obtain σ p lq
        where "s = (σ, (snd (sr p), lq))"
          and "lq  init qp"
          and "p  init (np i)"
          and "σ i = fst (sr p)"
          and "j. j  i  σ j  (fst  (λ(p, q). (fst (sr p), snd (sr p), q)))
                                                                        ` (init (np j) × init qp)"
        by auto
      from this(5) have "j. j  i  σ j  (fst  sr) ` init (np j)"
        by auto
      with p  init (np i) and σ i = fst (sr p) have "(σ, snd (sr p))  init (onp i)"
        by - (rule init [THEN subsetD], auto)
      with lq init qp have "((σ, snd (sr p)), lq)  init (onp i) × init qp"
        by simp
      hence "(σ, (snd (sr p), lq))  extg ` (init (onp i) × init qp)"
        by (rule rev_image_eqI) simp
      with s = (σ, (snd (sr p), lq)) show "s  init (onp i ⟨⟨i qp)"
        by simp
    qed
  next
    fix i s a s' σ σ'
    assume "σ i = fst ((λ(p, q). (fst (sr p), (snd (sr p), q))) s)"
       and "σ' i = fst ((λ(p, q). (fst (sr p), (snd (sr p), q))) s')"
       and "(s, a, s')  trans (np i ⟨⟨ qp)"
    then obtain p q p' q' where "s  = (p, q)"
                            and "s' = (p', q')"
                            and "σ i  = fst (sr p)"
                            and "σ' i = fst (sr p')"
      by (clarsimp split: prod.split_asm)
    from this(1-2) and (s, a, s')  trans (np i ⟨⟨ qp)
      have "((p, q), a, (p', q'))  parp_sos (trans (np i)) (trans qp)" by simp
    hence "((σ, (snd (sr p), q)), a, (σ', (snd (sr p'), q')))  trans (onp i ⟨⟨i qp)"
    proof cases
      assume "q' = q"
         and "(p, a, p')  trans (np i)"
         and "m. a  receive m"
      from σ i = fst (sr p) and σ' i = fst (sr p') this(2)
        have "((σ, snd (sr p)), a, (σ', snd (sr p')))  trans (onp i)" by (rule trans)
      with q' = q and m. a  receive m
        show "((σ, snd (sr p), q), a, (σ', (snd (sr p'), q')))  trans (onp i ⟨⟨i qp)"
          by (auto elim!: oparleft)
    next
      assume "p' = p"
         and "(q, a, q')  trans qp"
         and "m. a  send m"
      with σ i = fst (sr p) and σ' i = fst (sr p')
        show "((σ, snd (sr p), q), a, (σ', (snd (sr p'), q')))  trans (onp i ⟨⟨i qp)"
          by (auto elim!: oparright)
    next
      fix m
      assume "a = τ"
         and "(p, receive m, p')  trans (np i)"
         and "(q, send m, q')  trans qp"
      from σ i = fst (sr p) and σ' i = fst (sr p') this(2)
        have "((σ, snd (sr p)), receive m, (σ', snd (sr p')))  trans (onp i)"
          by (rule trans)
      with (q, send m, q')  trans qp and a = τ
        show "((σ, snd (sr p), q), a, (σ', (snd (sr p'), q')))  trans (onp i ⟨⟨i qp)"
          by (simp del: step_seq_tau) (rule oparboth)
    qed
    with s = (p, q) s' = (p', q')
      show "((σ, snd ((λ(p, q). (fst (sr p), (snd (sr p), q))) s)), a,
                 (σ', snd ((λ(p, q). (fst (sr p), (snd (sr p), q))) s')))  trans (onp i ⟨⟨i qp)"
        by simp
  next
    show "j. init (np j ⟨⟨ qp)  {}"
      by (clarsimp simp add: init_notempty init_qp_notempty)
  qed

end

Theory AWN_Main

(*  Title:       AWN_Main.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Import all AWN-related theories"

theory AWN_Main
imports AWN_SOS AWN_SOS_Labels OAWN_SOS_Labels AWN_Invariants
        OAWN_Convert OClosed_Transfer
begin

end

Theory Toy

(*  Title:       Toy.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
    Author:      Peter Höfner
*)

section "Simple toy example"

theory Toy
imports Main AWN_Main Qmsg_Lifting
begin

subsection "Messages used in the protocol"

datatype msg =
    Pkt data ip
  | Newpkt data ip

instantiation msg :: msg
begin
definition newpkt_def [simp]: "newpkt  λ(d,did). Newpkt d did"
definition eq_newpkt_def: "eq_newpkt m  case m of Newpkt d did   True | _  False" 

instance by intro_classes (simp add: eq_newpkt_def)
end

definition pkt :: "nat × nat  msg"
where "pkt  λ(no, sid). Pkt no sid"

lemma pkt_simp [simp]:
  "pkt(no, sid) = Pkt no sid"
  unfolding pkt_def by simp

lemma not_eq_newpkt_pkt [simp]: "¬eq_newpkt (Pkt no sid)"
  unfolding eq_newpkt_def by simp

subsection "Protocol model"

record state =
  id    :: "nat"
  no    :: "nat"
  nhid  :: "nat"
  (* all locals *)
  msg    :: "msg"
  num    :: "nat"
  sid    :: "nat"

abbreviation toy_init :: "ip  state"
where "toy_init i  
         id = i,
         no = 0,
         nhid = i,

         msg    = (SOME x. True),
         num    = (SOME x. True),
         sid    = (SOME x. True)
       "

lemma some_neq_not_eq [simp]: "¬((SOME x :: nat. x  i) = i)"
  by (subst some_eq_ex) (metis zero_neq_numeral)

definition clear_locals :: "state  state"
where "clear_locals ξ = ξ 
    msg    := (SOME x. True),
    num    := (SOME x. True),
    sid    := (SOME x. True)
  "

lemma clear_locals_but_not_globals [simp]:
  "id (clear_locals ξ) = id ξ"
  "no (clear_locals ξ) = no ξ"
  "nhid (clear_locals ξ) = nhid ξ"
  unfolding clear_locals_def by auto

definition is_newpkt
where "is_newpkt ξ  case msg ξ of
                       Newpkt data did  { ξnum := data }
                     | _  {}"

definition is_pkt
where "is_pkt ξ  case msg ξ of
                    Pkt num' sid'  { ξ num := num', sid := sid'  }
                  | _  {}"

lemmas is_msg_defs =
  is_pkt_def is_newpkt_def

lemma is_msg_inv_id [simp]:
  "ξ'  is_pkt ξ     id ξ' = id ξ"
  "ξ'  is_newpkt ξ  id ξ' = id ξ"
  unfolding is_msg_defs
  by (cases "msg ξ", clarsimp+)+

lemma is_msg_inv_sid [simp]:
  "ξ'  is_newpkt ξ  sid ξ' = sid ξ"
  unfolding is_msg_defs
  by (cases "msg ξ", clarsimp+)+

lemma is_msg_inv_no [simp]:
  "ξ'  is_pkt ξ     no ξ' = no ξ"
  "ξ'  is_newpkt ξ  no ξ' = no ξ"
  unfolding is_msg_defs
  by (cases "msg ξ", clarsimp+)+

lemma is_msg_inv_nhid [simp]:
  "ξ'  is_pkt ξ     nhid ξ' = nhid ξ"
  "ξ'  is_newpkt ξ  nhid ξ' = nhid ξ"
  unfolding is_msg_defs
  by (cases "msg ξ", clarsimp+)+

lemma is_msg_inv_msg [simp]:
  "ξ'  is_pkt ξ     msg ξ' = msg ξ"
  "ξ'  is_newpkt ξ  msg ξ' = msg ξ"
  unfolding is_msg_defs
  by (cases "msg ξ", clarsimp+)+

datatype pseqp =
    PToy

fun nat_of_seqp :: "pseqp  nat"
where
  "nat_of_seqp PToy = 1"

instantiation "pseqp" :: ord
begin
definition less_eq_seqp [iff]: "l1  l2 = (nat_of_seqp l1  nat_of_seqp l2)"
definition less_seqp [iff]:    "l1 < l2 = (nat_of_seqp l1 < nat_of_seqp l2)"
instance ..
end

abbreviation Toy
where
  "Toy  λ_. clear_locals call(PToy)"

fun ΓTOY :: "(state, msg, pseqp, pseqp label) seqp_env"
where
  "ΓTOY PToy = labelled PToy (
     receive(λmsg' ξ. ξ  msg := msg' ).
     ξ. ξ nhid := id ξ
     (   is_newpkt 
         (
             ξ. ξ no := max (no ξ) (num ξ)
             broadcast(λξ. pkt(no ξ, id ξ)). Toy()
         )
        is_pkt
       (
            ξ. num ξ > no ξ
               ξ. ξ no := num ξ
               ξ. ξ nhid := sid ξ
               broadcast(λξ. pkt(no ξ, id ξ)). Toy()
          ξ. num ξ  no ξ
               Toy()
       )
     ))"

declare ΓTOY.simps [simp del, code del]
lemmas ΓTOY_simps [simp, code] = ΓTOY.simps [simplified]

fun ΓTOY_skeleton
where "ΓTOY_skeleton PToy = seqp_skeleton (ΓTOY PToy)"

lemma ΓTOY_skeleton_wf [simp]:
  "wellformed ΓTOY_skeleton"
  proof (rule, intro allI)
    fix pn pn'
    show "call(pn')  stermsl (ΓTOY_skeleton pn)"
      by (cases pn) simp_all
  qed

declare ΓTOY_skeleton.simps [simp del, code del]
lemmas ΓTOY_skeleton_simps [simp, code] = ΓTOY_skeleton.simps [simplified ΓTOY_simps seqp_skeleton.simps]

lemma toy_proc_cases [dest]:
  fixes p pn
  assumes "p  ctermsl (ΓTOY pn)"
    shows "p  ctermsl (ΓTOY PToy)"
  using assms
  by (cases pn) simp_all

definition σTOY :: "ip  (state × (state, msg, pseqp, pseqp label) seqp) set"
where "σTOY i  {(toy_init i, ΓTOY PToy)}"

abbreviation ptoy
  :: "ip  (state × (state, msg, pseqp, pseqp label) seqp, msg seq_action) automaton"
where
  "ptoy i   init = σTOY i, trans = seqp_sos ΓTOY "

lemma toy_trans: "trans (ptoy i) = seqp_sos ΓTOY"
  by simp

lemma toy_control_within [simp]: "control_within ΓTOY (init (ptoy i))"
  unfolding σTOY_def by (rule control_withinI) (auto simp del: ΓTOY_simps)

lemma toy_wf [simp]:
  "wellformed ΓTOY"
  proof (rule, intro allI)
    fix pn pn'
    show "call(pn')  stermsl (ΓTOY pn)"
      by (cases pn) simp_all
  qed

lemmas toy_labels_not_empty [simp] = labels_not_empty [OF toy_wf]

lemma toy_ex_label [intro]: "l. llabels ΓTOY p"
  by (metis toy_labels_not_empty all_not_in_conv)

lemma toy_ex_labelE [elim]:
  assumes "llabels ΓTOY p. P l p"
      and "p l. P l p  Q"
    shows "Q"
 using assms by (metis toy_ex_label) 

lemma toy_simple_labels [simp]: "simple_labels ΓTOY"
  proof
    fix pn p
    assume "psubterms(ΓTOY pn)"
    thus "∃!l. labels ΓTOY p = {l}"
    by (cases pn) (simp_all cong: seqp_congs | elim disjE)+
  qed

lemma σTOY_labels [simp]: "(ξ, p)  σTOY i   labels ΓTOY p = {PToy-:0}"
  unfolding σTOY_def by simp

text ‹By default, we no longer let the simplifier descend into process terms.›

declare seqp_congs [cong]

(* configure the inv_cterms tactic *)
declare
  ΓTOY_simps [cterms_env]
  toy_proc_cases [ctermsl_cases]
  seq_invariant_ctermsI [OF toy_wf toy_control_within toy_simple_labels toy_trans, cterms_intros]
  seq_step_invariant_ctermsI [OF toy_wf toy_control_within toy_simple_labels toy_trans, cterms_intros]

subsection "Define an open version of the protocol"

definition σOTOY :: "((ip  state) × ((state, msg, pseqp, pseqp label) seqp)) set"
where "σOTOY  {(toy_init, ΓTOY PToy)}"

abbreviation optoy
  :: "ip  ((ip  state) × (state, msg, pseqp, pseqp label) seqp, msg seq_action) automaton"
where
  "optoy i   init = σOTOY, trans = oseqp_sos ΓTOY i "

lemma initiali_toy [intro!, simp]: "initiali i (init (optoy i)) (init (ptoy i))"
  unfolding σTOY_def σOTOY_def by rule simp_all

lemma oaodv_control_within [simp]: "control_within ΓTOY (init (optoy i))"
  unfolding σOTOY_def by (rule control_withinI) (auto simp del: ΓTOY_simps)

lemma σOTOY_labels [simp]: "(σ, p)  σOTOY   labels ΓTOY p = {PToy-:0}"
  unfolding σOTOY_def by simp

lemma otoy_trans: "trans (optoy i) = oseqp_sos ΓTOY i"
  by simp

(* configure the inv_cterms tactic *)
declare
  oseq_invariant_ctermsI [OF toy_wf oaodv_control_within toy_simple_labels otoy_trans, cterms_intros]
  oseq_step_invariant_ctermsI [OF toy_wf oaodv_control_within toy_simple_labels otoy_trans, cterms_intros]

subsection "Predicates"

definition msg_sender :: "msg  ip"
where "msg_sender m  case m of Pkt _ ipc  ipc"

lemma msg_sender_simps [simp]:
  "d did sid. msg_sender (Pkt d sid) = sid"
  unfolding msg_sender_def by simp_all

abbreviation not_Pkt :: "msg  bool"
where "not_Pkt m  case m of Pkt _ _  False | _  True"

definition nos_inc :: "state  state  bool"
where "nos_inc ξ ξ'  (no ξ  no ξ')"

definition msg_ok :: "(ip  state)  msg  bool"
where "msg_ok σ m  case m of Pkt num' sid'  num'  no (σ sid') | _  True"

lemma msg_okI [intro]:
  assumes "num' sid'. m = Pkt num' sid'  num'  no (σ sid')"
    shows "msg_ok σ m"
  using assms unfolding msg_ok_def
  by (auto split: msg.split)

lemma msg_ok_Pkt [simp]:
  "msg_ok σ (Pkt data src) = (data  no (σ src))"
  unfolding msg_ok_def by simp

lemma msg_ok_pkt [simp]:
  "msg_ok σ (pkt(data, src)) = (data  no (σ src))"
  unfolding msg_ok_def by simp

lemma msg_ok_Newpkt [simp]:
  "msg_ok σ (Newpkt data dst)"
  unfolding msg_ok_def by simp

lemma msg_ok_newpkt [simp]:
  "msg_ok σ (newpkt(data, dst))"
  unfolding msg_ok_def by simp

subsection "Sequential Invariants"

lemma seq_no_leq_num:
  "ptoy i  onl ΓTOY (λ(ξ, l). l{PToy-:7..PToy-:8}  no ξ  num ξ)"
  by inv_cterms

lemma seq_nos_incs:
  "ptoy i A onll ΓTOY (λ((ξ, _), _, (ξ', _)). nos_inc ξ ξ')"
  unfolding nos_inc_def
  by (inv_cterms inv add: onl_invariant_sterms [OF toy_wf seq_no_leq_num])

lemma seq_nos_incs':
  "ptoy i A (λ((ξ, _), _, (ξ', _)). nos_inc ξ ξ')"
  by (rule step_invariant_weakenE [OF seq_nos_incs]) (auto dest!: onllD)

lemma sender_ip_valid:
  "ptoy i A onll ΓTOY (λ((ξ, _), a, _). anycast (λm. msg_sender m = id ξ) a)"
  by inv_cterms

lemma id_constant:
  "ptoy i  onl ΓTOY (λ(ξ, _). id ξ = i)"
  by inv_cterms (simp add: σTOY_def)

lemma nhid_eq_id:
  "ptoy i  onl ΓTOY (λ(ξ, l). l{PToy-:2..PToy-:8}  nhid ξ = id ξ)"
  by inv_cterms

lemma seq_msg_ok:
  "ptoy i A onll ΓTOY (λ((ξ, _), a, _).
                anycast (λm. case m of Pkt num' sid'  num' = no ξ  sid' = i | _  True) a)"
  by (inv_cterms inv add: onl_invariant_sterms [OF toy_wf id_constant])

lemma nhid_eq_i:
  "ptoy i  onl ΓTOY (λ(ξ, l). l{PToy-:2..PToy-:8}  nhid ξ = i)"
  proof (rule invariant_arbitraryI, clarify intro!: onlI impI)
    fix ξ p l n
    assume "(ξ, p)  reachable (ptoy i) TT"
       and "l  labels ΓTOY p"
       and "l  {PToy-:2..PToy-:8}"
    from this(1-3) have "nhid ξ = id ξ"
      by - (drule invariantD [OF nhid_eq_id], auto)
    moreover with (ξ, p)  reachable (ptoy i) TT› and l  labels ΓTOY p have "id ξ = i"
      by (auto dest: invariantD [OF id_constant])
    ultimately show "nhid ξ = i"
      by simp
  qed

subsection "Global Invariants"

lemma nos_incD [dest]:
  assumes "nos_inc ξ ξ'"
    shows "no ξ  no ξ'"
  using assms unfolding nos_inc_def .

lemma nos_inc_simp [simp]:
  "nos_inc ξ ξ' = (no ξ  no ξ')"
  unfolding nos_inc_def ..

lemmas oseq_nos_incs =
  open_seq_step_invariant [OF seq_nos_incs initiali_toy otoy_trans toy_trans,
                           simplified seqll_onll_swap]

lemmas oseq_no_leq_num =
  open_seq_invariant [OF seq_no_leq_num initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]

lemma all_nos_inc:
  shows "optoy i A (otherwith nos_inc {i} S,
                      other nos_inc {i} →)
                       onll ΓTOY (λ((σ, _), a, (σ', _)). (j. nos_inc (σ j) (σ' j)))"
  proof -
    have *: "σ σ' a.  otherwith nos_inc {i} S σ σ' a; no (σ i)  no (σ' i) 
                        j. no (σ j)  no (σ' j)"
      by (auto dest!: otherwith_syncD)
    show ?thesis
      by (inv_cterms
            inv add: oseq_step_invariant_sterms [OF oseq_nos_incs [THEN oinvariant_step_anyact]
                                                                                   toy_wf otoy_trans]
            simp add: seqllsimp) (auto elim!: *)
  qed

lemma oreceived_msg_inv:
  assumes other: "σ σ' m.  P σ m; other Q {i} σ σ'   P σ' m"
      and local: "σ m. P σ m  P (σ(i := σ imsg := m)) m"
    shows "optoy i  (otherwith Q {i} (orecvmsg P), other Q {i} →)
                       onl ΓTOY (λ(σ, l). l  {PToy-:1}  P σ (msg (σ i)))"
  proof (inv_cterms, intro impI)
    fix σ σ' l
    assume "l = PToy-:1  P σ (msg (σ i))"
       and "l = PToy-:1"
       and "other Q {i} σ σ'"
    from this(1-2) have "P σ (msg (σ i))" ..
    hence "P σ' (msg (σ i))" using ‹other Q {i} σ σ'
      by (rule other)
    moreover from ‹other Q {i} σ σ' have "σ' i = σ i" ..
    ultimately show "P σ' (msg (σ' i))" by simp
  next
    fix σ σ' msg
    assume "otherwith Q {i} (orecvmsg P) σ σ' (receive msg)"
       and "σ' i = σ imsg := msg"
    from this(1) have "P σ msg"
                 and "j. ji  Q (σ j) (σ' j)" by auto
    from this(1) have "P (σ(i := σ imsg := msg)) msg" by (rule local)
    thus "P σ' msg"
    proof (rule other)
      from σ' i = σ imsg := msg and j. ji  Q (σ j) (σ' j)
        show "other Q {i} (σ(i := σ imsg := msg)) σ'"
          by - (rule otherI, auto)
    qed
  qed

lemma msg_ok_other_nos_inc [elim]:
  assumes "msg_ok σ m"
      and "other nos_inc {i} σ σ'"
    shows "msg_ok σ' m"
  proof (cases m)
    fix num sid
    assume "m = Pkt num sid"
    with ‹msg_ok σ m have "num  no (σ sid)" by simp
    also from ‹other nos_inc {i} σ σ' have "no (σ sid)  no (σ' sid)"
      by (rule otherE) (metis eq_iff nos_incD)
    finally have "num  no (σ' sid)" .
    with m = Pkt num sid show ?thesis
      by simp
  qed simp

lemma msg_ok_no_leq_no [simp, elim]:
  assumes "msg_ok σ m"
      and "j. no (σ j)  no (σ' j)"
    shows "msg_ok σ' m"
  using assms(1) proof (cases m)
    fix num sid
    assume "m = Pkt num sid"
    with ‹msg_ok σ m have "num  no (σ sid)" by simp
    also from j. no (σ j)  no (σ' j) have "no (σ sid)  no (σ' sid)"
      by simp
    finally have "num  no (σ' sid)" .
    with m = Pkt num sid show ?thesis
      by simp
  qed (simp add: assms(1))

lemma oreceived_msg_ok:
  "optoy i  (otherwith nos_inc {i} (orecvmsg msg_ok),
               other nos_inc {i} →)
              onl ΓTOY (λ(σ, l). l{PToy-:1..}  msg_ok σ (msg (σ i)))"
  (is "_  (?S, ?U →) _")
  proof (inv_cterms inv add: oseq_step_invariant_sterms [OF all_nos_inc toy_wf otoy_trans],
         intro impI, elim impE)
    fix σ σ'
    assume "msg_ok σ (msg (σ i))"
       and other: "other nos_inc {i} σ σ'"
    moreover from other have "msg (σ' i) = msg (σ i)"
      by (clarsimp elim!: otherE)
    ultimately show "msg_ok σ' (msg (σ' i))"
      by (auto)
  next
    fix p l σ a q l' σ' pp p' m
    assume a1: "(σ', p')  oreachable (optoy i) ?S ?U"
       and a2: "PToy-:1  labels ΓTOY p'"
       and a3: "σ' i = σ imsg := m"
    have inv: "optoy i  (?S, ?U →) onl ΓTOY (λ(σ, l). l  {PToy-:1}  msg_ok σ (msg (σ i)))"
    proof (rule oreceived_msg_inv)
      fix σ σ' m
      assume "msg_ok σ m"
         and "other nos_inc {i} σ σ'"
      thus "msg_ok σ' m" ..
    next
      fix σ m
      assume "msg_ok σ m"
      thus "msg_ok (σ(i := σ imsg := m)) m"
        by (cases m) auto
    qed
    from a1 a2 a3 show "msg_ok σ' m"
      by (clarsimp dest!: oinvariantD [OF inv] onlD)
  qed simp

lemma is_pkt_handler_num_leq_no:
  shows "optoy i  (otherwith nos_inc {i} (orecvmsg msg_ok),
                      other nos_inc {i} →)
                    onl ΓTOY (λ(σ, l). l{PToy-:6..PToy-:10}  num (σ i)  no (σ (sid (σ i))))"
  proof -
    { fix σ σ'
      assume "j. no (σ j)  no (σ' j)"
         and "num (σ i)  no (σ (sid (σ i)))"
      have "num (σ i)  no (σ' (sid (σ i)))"
      proof -
        note ‹num (σ i)  no (σ (sid (σ i)))
        also from j. no (σ j)  no (σ' j) have "no (σ (sid (σ i)))  no (σ' (sid (σ i)))"
          by auto
        finally show ?thesis .
      qed
    } note solve_step = this
    show ?thesis
    proof (inv_cterms inv add: oseq_step_invariant_sterms [OF all_nos_inc toy_wf otoy_trans]
                               onl_oinvariant_sterms [OF toy_wf oreceived_msg_ok]
                        solve: solve_step, intro impI, elim impE)
      fix σ σ'
      assume *: "num (σ i)  no (σ (sid (σ i)))"
         and "other nos_inc {i} σ σ'"
      from this(2) obtain "i{i}. σ' i = σ i"
                      and "j. j  {i}  nos_inc (σ j) (σ' j)" ..
      show "num (σ' i)  no (σ' (sid (σ' i)))"      
      proof (cases "sid (σ i) = i")
        assume "sid (σ i) = i"
        with * i{i}. σ' i = σ i
        show ?thesis by simp
      next
        assume "sid (σ i)  i"
        with j. j  {i}  nos_inc (σ j) (σ' j)
          have "no (σ (sid (σ i)))  no (σ' (sid (σ i)))" by simp
        with * i{i}. σ' i = σ i
        show ?thesis by simp
      qed
    next
      fix p l σ a q l' σ' pp p'
      assume "msg_ok σ (msg (σ i))"
         and "j. no (σ j)  no (σ' j)"
         and "σ' i  is_pkt (σ i)"
      show "num (σ' i)  no (σ' (sid (σ' i)))"
      proof (cases "msg (σ i)")
        fix num' sid'
        assume "msg (σ i) = Pkt num' sid'"
        with σ' i  is_pkt (σ i) obtain "num (σ' i) = num'"
                                      and "sid (σ' i) = sid'"
          unfolding is_pkt_def by auto
        with ‹msg (σ i) = Pkt num' sid' and ‹msg_ok σ (msg (σ i))
          have "num (σ' i)  no (σ (sid (σ' i)))"
            by simp
        also from j. no (σ j)  no (σ' j) have "no (σ (sid (σ' i)))  no (σ' (sid (σ' i)))" ..
        finally show ?thesis .
      next
        fix num' sid'
        assume "msg (σ i) = Newpkt num' sid'"
        with σ' i  is_pkt (σ i) have False
          unfolding is_pkt_def by simp
        thus ?thesis ..
      qed
    qed
  qed

lemmas oseq_id_constant =
  open_seq_invariant [OF id_constant initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]

lemmas oseq_nhid_eq_i =
  open_seq_invariant [OF nhid_eq_i initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]
  
lemmas oseq_nhid_eq_id =
  open_seq_invariant [OF nhid_eq_id initiali_toy otoy_trans toy_trans,
                      simplified seql_onl_swap]

lemma oseq_bigger_than_next:
  shows "optoy i  (otherwith nos_inc {i} (orecvmsg msg_ok),
                      other nos_inc {i} →) global (λσ. no (σ i)  no (σ (nhid (σ i))))"
    (is "_  (?S, ?U →) ?P")
  proof -
    have nhidinv: "optoy i  (?S, ?U →)
                              onl ΓTOY (λ(σ, l). l{PToy-:2..PToy-:8}
                                                     nhid (σ i) = id (σ i))"
      by (rule oinvariant_weakenE [OF oseq_nhid_eq_id]) (auto simp: seqlsimp)
    have idinv: "optoy i  (?S, ?U →) onl ΓTOY (λ(σ, l). id (σ i) = i)"
      by (rule oinvariant_weakenE [OF oseq_id_constant]) (auto simp: seqlsimp)
    { fix σ σ' a
      assume "no (σ i)  no (σ (nhid (σ i)))"
         and "j. nos_inc (σ j) (σ' j)"
      note this(1)
      also from j. nos_inc (σ j) (σ' j) have "no (σ (nhid (σ i)))  no (σ' (nhid (σ i)))"
        by auto
      finally have "no (σ i)  no (σ' (nhid (σ i)))" ..
    } note * = this
    have "optoy i  (otherwith nos_inc {i} (orecvmsg msg_ok),
                      other nos_inc {i} →)
                     onl ΓTOY (λ(σ, l). no (σ i)  no (σ (nhid (σ i))))"
    proof (inv_cterms
             inv add: onl_oinvariant_sterms [OF toy_wf oseq_no_leq_num [THEN oinvariant_anyact]]
                      oseq_step_invariant_sterms [OF all_nos_inc toy_wf otoy_trans]
                      onl_oinvariant_sterms [OF toy_wf is_pkt_handler_num_leq_no]
                      onl_oinvariant_sterms [OF toy_wf nhidinv]
                      onl_oinvariant_sterms [OF toy_wf idinv]
             simp add: seqlsimp seqllsimp
             simp del: nos_inc_simp
                solve: *)
      fix σ p l
      assume "(σ, p)  σOTOY"
      thus "no (σ i)  no (σ (nhid (σ i)))"
        by (simp add: σOTOY_def)
    next
      fix σ σ' p l
      assume or: "(σ, p)  oreachable (optoy i) ?S ?U"
         and "l  labels ΓTOY p"
         and "no (σ i)  no (σ (nhid (σ i)))"
         and "other nos_inc {i} σ σ'"
      show "no (σ' i)  no (σ' (nhid (σ' i)))"
      proof (cases "nhid (σ' i) = i")
        assume "nhid (σ' i) = i"
        with ‹no (σ i)  no (σ (nhid (σ i))) show ?thesis
          by simp
      next
        assume "nhid (σ' i)  i"
        moreover from ‹other nos_inc {i} σ σ' [THEN other_localD] have "σ' i = σ i"
          by simp
        ultimately have "no (σ (nhid (σ i)))  no (σ' (nhid (σ' i)))"
          using ‹other nos_inc {i} σ σ' and σ' i = σ i by (auto)
        with ‹no (σ i)  no (σ (nhid (σ i))) and σ' i = σ i show ?thesis
          by simp
      qed
    next
      fix p l σ a q l' σ' pp p'
      assume "no (σ i)  num (σ i)"
         and "num (σ i)  no (σ (sid (σ i)))"
         and "j. nos_inc (σ j) (σ' j)"
      from this(1-2) have "no (σ i)  no (σ (sid (σ i)))"
        by (rule le_trans)
      also from j. nos_inc (σ j) (σ' j)
        have "no (σ (sid (σ i)))  no (σ' (sid (σ i)))"
          by auto
      finally show "no (σ i)  no (σ' (sid (σ i)))" ..
    qed
    thus ?thesis
      by (rule oinvariant_weakenE)
         (auto simp: onl_def)
  qed

lemma anycast_weakenE [elim]:
  assumes "anycast P a"
      and "m. P m  Q m"
  shows "anycast Q a"
  using assms unfolding anycast_def
  by (auto split: seq_action.split)

lemma oseq_msg_ok:
  "optoy i A (act TT, other U {i} →) globala (λ(σ, a, _). anycast (msg_ok σ) a)"
  by (rule ostep_invariant_weakenE [OF open_seq_step_invariant
            [OF seq_msg_ok initiali_toy otoy_trans toy_trans, simplified seql_onl_swap]])
     (auto simp: seqllsimp dest!: onllD elim!: anycast_weakenE intro!: msg_okI)

subsection "Lifting"

lemma opar_bigger_than_next:
  shows "optoy i ⟨⟨i qmsg  (otherwith nos_inc {i} (orecvmsg msg_ok),
                      other nos_inc {i} →) global (λσ. no (σ i)  no (σ (nhid (σ i))))"
  proof (rule lift_into_qmsg [OF oseq_bigger_than_next])
    fix σ σ' m
    assume "j. nos_inc (σ j) (σ' j)"
       and "msg_ok σ m"
    from this(2) show "msg_ok σ' m"
    proof (cases m, simp only: msg_ok_Pkt)
      fix num' sid'
      assume "num'  no (σ sid')"
      also from j. nos_inc (σ j) (σ' j) have "no (σ sid')  no (σ' sid')"
        by simp
      finally show "num'  no (σ' sid')" .
    qed simp
  next
    show "optoy i A (otherwith nos_inc {i} (orecvmsg msg_ok), other nos_inc {i} →)
                      globala (λ(σ, _, σ'). nos_inc (σ i) (σ' i))"
      by (rule ostep_invariant_weakenE [OF open_seq_step_invariant
                                         [OF seq_nos_incs initiali_toy otoy_trans toy_trans]])
         (auto simp: seqllsimp dest!: onllD)
  qed simp

lemma onode_bigger_than_next:
  "i : optoy i ⟨⟨i qmsg : Rio
      (otherwith nos_inc {i} (oarrivemsg msg_ok), other nos_inc {i} →)
        global (λσ. no (σ i)  no (σ (nhid (σ i))))"
  by (rule node_lift [OF opar_bigger_than_next])

lemma node_local_nos_inc:
  "i : optoy i ⟨⟨i qmsg : Rio A (λσ _. oarrivemsg (λ_ _. True) σ, other (λ_ _. True) {i} →)
                                     globala (λ(σ, _, σ'). nos_inc (σ i) (σ' i))"
  proof (rule node_lift_step_statelessassm)
    have "optoy i A (λσ _. orecvmsg (λ_ _. True) σ, other (λ_ _. True) {i} →)
                      globala (λ(σ, _, σ'). nos_inc (σ i) (σ' i))"
      by (rule ostep_invariant_weakenE [OF oseq_nos_incs])
         (auto simp: seqllsimp dest!: onllD)
    thus "optoy i ⟨⟨i qmsg A (λσ _. orecvmsg (λ_ _. True) σ, other (λ_ _. True) {i} →)
                                globala (λ(σ, _, σ'). nos_inc (σ i) (σ' i))"
      by (rule lift_step_into_qmsg_statelessassm) auto
  qed simp

lemma opnet_bigger_than_next:
  "opnet (λi. optoy i ⟨⟨i qmsg) n
      (otherwith nos_inc (net_tree_ips n) (oarrivemsg msg_ok),
         other nos_inc (net_tree_ips n) →)
        global (λσ. inet_tree_ips n. no (σ i)  no (σ (nhid (σ i))))"
  proof (rule pnet_lift [OF onode_bigger_than_next])
    fix i Ri
    have "i : optoy i ⟨⟨i qmsg : Rio A (λσ _. oarrivemsg msg_ok σ, other (λ_ _. True) {i} →)
                                            globala (λ(σ, a, _). castmsg (msg_ok σ) a)"
    proof (rule node_lift_anycast_statelessassm)
      have "optoy i A (λσ _. orecvmsg (λ_ _. True) σ, other (λ_ _. True) {i} →)
                        globala (λ(σ, a, _). anycast (msg_ok σ) a)"
        by (rule ostep_invariant_weakenE [OF oseq_msg_ok]) auto
      hence "optoy i ⟨⟨i qmsg A (λσ _. orecvmsg (λ_ _. True) σ, other (λ_ _. True) {i} →)
                                   globala (λ(σ, a, _). anycast (msg_ok σ) a)"
        by (rule lift_step_into_qmsg_statelessassm) auto
      thus "optoy i ⟨⟨i qmsg A (λσ _. orecvmsg msg_ok σ, other (λ_ _. True) {i} →)
                                  globala (λ(σ, a, _). anycast (msg_ok σ) a)"
        by (rule ostep_invariant_weakenE) auto
    qed
    thus "i : optoy i ⟨⟨i qmsg : Rio A (λσ _. oarrivemsg msg_ok σ, other nos_inc {i} →)
                                            globala (λ(σ, a, _). castmsg (msg_ok σ) a)"
      by (rule ostep_invariant_weakenE) auto
  next
    fix i Ri
    show "i : optoy i ⟨⟨i qmsg : Rio A (λσ _. oarrivemsg msg_ok σ,
                                            other nos_inc {i} →)
             globala (λ(σ, a, σ'). a  τ  (d. a  i:deliver(d))  nos_inc (σ i) (σ' i))"
      by (rule ostep_invariant_weakenE [OF node_local_nos_inc]) auto
  next
    fix i R
    show "i : optoy i ⟨⟨i qmsg : Ro A (λσ _. oarrivemsg msg_ok σ,
                                           other nos_inc {i} →)
             globala (λ(σ, a, σ'). a = τ  (d. a = i:deliver(d))  nos_inc (σ i) (σ' i))"
      by (rule ostep_invariant_weakenE [OF node_local_nos_inc]) auto
  qed simp_all

lemma ocnet_bigger_than_next:
  "oclosed (opnet (λi. optoy i ⟨⟨i qmsg) n)
      (λ_ _ _. True, other nos_inc (net_tree_ips n) →)
        global (λσ. inet_tree_ips n. no (σ i)  no (σ (nhid (σ i))))"
  proof (rule inclosed_closed)
    show "opnet (λi. optoy i ⟨⟨i qmsg) n
             (otherwith (=) (net_tree_ips n) inoclosed, other nos_inc (net_tree_ips n) →)
               global (λσ. inet_tree_ips n. no (σ i)  no (σ (nhid (σ i))))"
    proof (rule oinvariant_weakenE [OF opnet_bigger_than_next])
      fix s s':: "nat  state" and a :: "msg node_action"
      assume "otherwith (=) (net_tree_ips n) inoclosed s s' a"
      thus "otherwith nos_inc (net_tree_ips n) (oarrivemsg msg_ok) s s' a"
      proof (rule otherwithE, intro otherwithI)
        assume "inoclosed s a"
           and "j. j  net_tree_ips n  s j = s' j"
           and "otherwith ((=)) (net_tree_ips n) inoclosed s s' a"
        thus "oarrivemsg msg_ok s a"
          by (cases a) auto
      qed auto
    qed simp
  qed

subsection "Transfer"

definition
  initmissing :: "(nat  state option) × 'a  (nat  state) × 'a"
where
  "initmissing σ = (λi. case (fst σ) i of None  toy_init i | Some s  s, snd σ)"

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i  net_ips σ"
    shows "fst (initmissing (netgmap fst σ)) i = toy_init i"
  using assms unfolding initmissing_def by simp

lemma fst_initmissing_netgmap_pair_fst [simp]:
  "fst (initmissing (netgmap (λ(p, q). (fst (Fun.id p), snd (Fun.id p), q)) s))
                                               = fst (initmissing (netgmap fst s))"
  unfolding initmissing_def by auto

interpretation toy_openproc: openproc ptoy optoy Fun.id
  rewrites "toy_openproc.initmissing = initmissing"
  proof -
    show "openproc ptoy optoy Fun.id"
    proof unfold_locales
      fix i :: ip
      have "{(σ, ζ). (σ i, ζ)  σTOY i  (j. j  i  σ j  fst ` σTOY j)}  σOTOY"
        unfolding σTOY_def σOTOY_def
        proof (rule equalityD1)
          show "f p. {(σ, ζ). (σ i, ζ)  {(f i, p)}  (j. j  i
                       σ j  fst ` {(f j, p)})} = {(f, p)}"
            by (rule set_eqI) auto
        qed
      thus "{ (σ, ζ) |σ ζ s. s  init (ptoy i)
                              (σ i, ζ) = Fun.id s
                              (j. ji  σ j  (fst o Fun.id) ` init (ptoy j)) }  init (optoy i)"
        by simp
    next
      show "j. init (ptoy j)  {}"
        unfolding σTOY_def by simp
    next
      fix i s a s' σ σ'
      assume "σ i = fst (Fun.id s)"
         and "σ' i = fst (Fun.id s')"
         and "(s, a, s')  trans (ptoy i)"
      then obtain q q' where "s = (σ i, q)"
                         and "s' = (σ' i, q')"
                         and "((σ i, q), a, (σ' i, q'))  trans (ptoy i)" 
         by (cases s, cases s') auto
      from this(3) have "((σ, q), a, (σ', q'))  trans (optoy i)"
        by simp (rule open_seqp_action [OF toy_wf])

      with s = (σ i, q) and s' = (σ' i, q')
        show "((σ, snd (Fun.id s)), a, (σ', snd (Fun.id s')))  trans (optoy i)"
          by simp
    qed
    then interpret op0: openproc ptoy optoy Fun.id .
    have [simp]: "i. (SOME x. x  (fst o Fun.id) ` init (ptoy i)) = toy_init i"
      unfolding σTOY_def by simp
    hence "i. openproc.initmissing ptoy Fun.id i = initmissing i"
      unfolding op0.initmissing_def op0.someinit_def initmissing_def
      by (auto split: option.split)
    thus "openproc.initmissing ptoy Fun.id = initmissing" ..
  qed

lemma fst_initmissing_netgmap_default_toy_init_netlift:
  "fst (initmissing (netgmap sr s)) = default toy_init (netlift sr s)"
  unfolding initmissing_def default_def
  by (simp add: fst_netgmap_netlift del: One_nat_def)

definition
  netglobal :: "((nat  state)  bool)  ((state × 'b) × 'c) net_state  bool"
where
  "netglobal P  (λs. P (default toy_init (netlift fst s)))"

interpretation toy_openproc_par_qmsg: openproc_parq ptoy optoy Fun.id qmsg
  rewrites "toy_openproc_par_qmsg.netglobal = netglobal"
    and "toy_openproc_par_qmsg.initmissing = initmissing"
  proof -
    show "openproc_parq ptoy optoy Fun.id qmsg"
      by (unfold_locales) simp
    then interpret opq: openproc_parq ptoy optoy Fun.id qmsg .

    have im: "σ. openproc.initmissing (λi. ptoy i ⟨⟨ qmsg) (λ(p, q). (fst (Fun.id p), snd (Fun.id p), q)) σ
                                                                                    = initmissing σ"
      unfolding opq.initmissing_def opq.someinit_def initmissing_def
      unfolding σTOY_def σQMSG_def by (clarsimp cong: option.case_cong)
    thus "openproc.initmissing (λi. ptoy i ⟨⟨ qmsg) (λ(p, q). (fst (Fun.id p), snd (Fun.id p), q)) = initmissing"
      by (rule ext)

    have "P σ. openproc.netglobal (λi. ptoy i ⟨⟨ qmsg) (λ(p, q). (fst (Fun.id p), snd (Fun.id p), q)) P σ
                                                                                = netglobal P σ"
      unfolding opq.netglobal_def netglobal_def opq.initmissing_def initmissing_def opq.someinit_def
      unfolding σTOY_def σQMSG_def
      by (clarsimp cong: option.case_cong
                   simp del: One_nat_def
                   simp add: fst_initmissing_netgmap_default_toy_init_netlift
                                                  [symmetric, unfolded initmissing_def])
    thus "openproc.netglobal (λi. ptoy i ⟨⟨ qmsg) (λ(p, q). (fst (Fun.id p), snd (Fun.id p), q)) = netglobal"
      by auto
  qed

subsection "Final result"

lemma bigger_than_next:
  assumes "wf_net_tree n"
  shows "closed (pnet (λi. ptoy i ⟨⟨ qmsg) n)  netglobal (λσ. i. no (σ i)  no (σ (nhid (σ i))))"
        (is "_  netglobal (λσ. i. ?inv σ i)")
  proof -
    from ‹wf_net_tree n
      have proto: "closed (pnet (λi. ptoy i ⟨⟨ qmsg) n)
                       netglobal (λσ. inet_tree_ips n. no (σ i)  no (σ (nhid (σ i))))"
        by (rule toy_openproc_par_qmsg.close_opnet [OF _ ocnet_bigger_than_next])
    show ?thesis
    unfolding invariant_def opnet_sos.opnet_tau1
    proof (rule, simp only: toy_openproc_par_qmsg.netglobalsimp
                            fst_initmissing_netgmap_pair_fst, rule allI)
      fix σ i
      assume sr: "σ  reachable (closed (pnet (λi. ptoy i ⟨⟨ qmsg) n)) TT"
      hence "inet_tree_ips n. ?inv (fst (initmissing (netgmap fst σ))) i"
        by - (drule invariantD [OF proto],
              simp only: toy_openproc_par_qmsg.netglobalsimp
                         fst_initmissing_netgmap_pair_fst)
      thus "?inv (fst (initmissing (netgmap fst σ))) i"
      proof (cases "inet_tree_ips n")
        assume "inet_tree_ips n"
        from sr have "σ  reachable (pnet (λi. ptoy i ⟨⟨ qmsg) n) TT" ..
        hence "net_ips σ = net_tree_ips n" ..
        with inet_tree_ips n have "inet_ips σ" by simp
        hence "(fst (initmissing (netgmap fst σ))) i = toy_init i"
          by simp
        thus ?thesis by simp
      qed metis
    qed
  qed

end

Theory AWN_Term_Graph

(*  Title:       AWN_Term_Graph.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)
theory AWN_Term_Graph
imports AWN_Cterms
begin

datatype ('p, 'l) node =
    RootNode 'p
  | InternalNode 'l

datatype ('p, 'l) link =
    ILink "('p, 'l) node" "('p, 'l) node"
  | ELink "('p, 'l) node" "('p, 'l) node"

definition gseqp'_fails where "gseqp'_fails = []"
declare [[code abort: gseqp'_fails]]

fun gseqp'
  :: "('s, 'm, 'p, 'l) seqp_env  ('s, 'm, 'p, 'l) seqp  ('p, 'l) node list"
where
    "gseqp' Γ ({l}_ _)                = [InternalNode l]"
  | "gseqp' Γ ({l}_ _)                = [InternalNode l]"
  | "gseqp' Γ ({l}unicast(_, _)._  _) = [InternalNode l]"
  | "gseqp' Γ ({l}broadcast(_). _)     = [InternalNode l]"
  | "gseqp' Γ ({l}groupcast(_, _). _)  = [InternalNode l]"
  | "gseqp' Γ ({l}send(_)._)           = [InternalNode l]"
  | "gseqp' Γ ({l}deliver(_)._)        = [InternalNode l]"
  | "gseqp' Γ ({l}receive(_)._)        = [InternalNode l]"
  | "gseqp' Γ (p1  p2)                = gseqp' Γ p1 @ gseqp' Γ p2"
  | "gseqp' Γ (call(pn))               = gseqp'_fails"
(*
(* It would be better to define this function for all wellformed Γ, as shown
   below, but I can't get the code generator to work smoothly with the
   conditional simp rules. *)

  | "gseqp' Γ (call(pn))               = gseqp' Γ (Γ pn)"
  by pat_completeness auto

lemma gseqp'_termination:
  assumes "wellformed Γ"
    shows "gseqp'_dom (Γ, p)"
  proof -
    have gseqp'_rel':
      "gseqp'_rel = (λgq gp. (gq, gp) ∈ {((Γ, q), (Γ', p)). Γ = Γ' ∧ p ↝Γ q})"
      by (rule ext)+ (auto simp: gseqp'_rel.simps elim: microstep.cases)

    from assms have "∀x. x ∈ acc {(q, p). p ↝Γ q}"
      unfolding wellformed_def by (simp add: wf_acc_iff)
    hence "p ∈ acc {(q, p). p ↝Γ q}" ..

    hence "(Γ, p) ∈ acc {((Γ, q), (Γ', p)). Γ = Γ' ∧ p ↝Γ q}"
      by (rule acc_induct) (auto intro: accI)

    thus "gseqp'_dom (Γ, p)" unfolding gseqp'_rel' accp_acc_eq .
  qed

declare gseqp'.psimps [simp, code del]
lemmas gseqp'_psimps[simp] = gseqp'.psimps [OF gseqp'_termination]
   and gseqp'_pinduct = gseqp'.pinduct [OF gseqp'_termination]
*)

fun gseqp :: "('s, 'm, 'p, 'l) seqp_env  ('s, 'm, 'p, 'l) seqp
               ('p, 'l) node list * ('p, 'l) node list * ('p, 'l) link list"
where
    "gseqp Γ ({l}_ p)                = (let me = InternalNode l in
                                          let (next, acc, links) = gseqp Γ p in
                                          ([me], me # acc, map (ILink me) next @ links))"
  | "gseqp Γ ({l}_ p)                = (let me = InternalNode l in
                                          let (next, acc, links) = gseqp Γ p in
                                          ([me], me # acc, map (ILink me) next @ links))"
  | "gseqp Γ (p1  p2)                = (let (next1, acc1, links1) = gseqp Γ p1 in
                                          let (next2, acc2, links2) = gseqp Γ p2 in
                                          (next1 @ next2, acc1 @ acc2, links1 @ links2))"
  | "gseqp Γ ({l}unicast(_, _).p  q) = (let me = InternalNode l in
                                          let (next1, acc1, links1) = gseqp Γ p in
                                          let (next2, acc2, links2) = gseqp Γ q in
                                          ([me], me # acc1 @ acc2,
                                        map (ELink me) (next1 @ next2) @ links1 @ links2))"
  | "gseqp Γ ({l}broadcast(_). p)     = (let me = InternalNode l in
                                          let (next, acc, links) = gseqp Γ p in
                                         ([me], me # acc, map (ELink me) next @ links))"
  | "gseqp Γ ({l}groupcast(_, _). p)  = (let me = InternalNode l in
                                          let (next, acc, links) = gseqp Γ p in
                                          ([me], me # acc, map (ELink me) next @ links))"
  | "gseqp Γ ({l}send(_).p)           = (let me = InternalNode l in
                                          let (next, acc, links) = gseqp Γ p in
                                          ([me], me # acc, map (ELink me) next @ links))"
  | "gseqp Γ ({l}deliver(_).p)        = (let me = InternalNode l in
                                          let (next, acc, links) = gseqp Γ p in
                                          ([me], me # acc, map (ELink me) next @ links))"
  | "gseqp Γ ({l}receive(_).p)        = (let me = InternalNode l in
                                          let (next, acc, links) = gseqp Γ p in
                                          ([me], me # acc, map (ELink me) next @ links))"
  | "gseqp Γ (call(pn))               = (gseqp' Γ (Γ pn), [], [])"

definition graph_of_other :: "('s, 'm, 'p, 'l) seqp_env
                               (('p, 'l) node list * ('p, 'l) link list)
                               'p
                               ('p, 'l) node list * ('p, 'l) link list"
where
  "graph_of_other Γ r pn = (let (next, acc, links) = gseqp Γ (Γ pn) in
                            (acc @ fst r, links @ snd r))"

definition graph_of_root :: "('s, 'm, 'p, 'l) seqp_env
                              (('p, 'l) node list * ('p, 'l) link list)
                              'p
                              ('p, 'l) node list * ('p, 'l) link list"
where
  "graph_of_root Γ r pn = (let me = RootNode pn in
                           let (next, acc, links) = gseqp Γ (Γ pn) in
                           (acc @ fst r @ [me], map (ILink me) next @ links @ snd r))"

definition graph_of_seqp :: "('s, 'm, 'p, 'l) seqp_env
                              'p list
                              ('p, 'l) node list * ('p, 'l) link list"
where
  "graph_of_seqp Γ pns = map_prod (rev  remdups) remdups
                           (foldl (graph_of_other Γ) (graph_of_root Γ ([], []) (hd pns)) (tl pns))"

definition graph_of_seqps :: "('s, 'm, 'p, 'l) seqp_env
                               'p list
                               ('p, 'l) node list * ('p, 'l) link list"
where
  "graph_of_seqps Γ pns = map_prod (rev  remdups) remdups (foldl (graph_of_root Γ) ([], [])
                                   (List.rev pns))"

end